$CONTROL MAP,CODE,USLINIT                                               00010000
<< FILEIO - File System Record Operations - Module 97 >>                00012000
<< HP32002C MPE source C.00.00 >>                                       00014000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00016000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00018000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00020000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00022000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00024000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00026000
                                                                        00028000
$SET X0=OFF,X1=ON, X2=ON, X3=OFF                                        00030000
$SET X9=ON  <<ALLOW RIO FILES>>                                <<01011>>00032000
                                                                        00034000
$ TITLE "  MPE-IV FILE SYSTEM - RECORD OPERATIONS - DECLARATIONS "      00036000
$ THIRTY                                                                00038000
$ CONTROL MAIN = FILEIO                                                 00040000
BEGIN                                                                   00042000
                                                                        00044000
<<----------------------------------------------------------------------00046000
*                       3000/30 FILE SYSTEM                            *00048000
*                                                                      *00050000
*  TOGGLES:                                                            *00052000
*     X0   ENABLES CODE THAT PRINTS THE PROCEDURE NAME AND CALLS       *00054000
*          DEBUG UPON ENTRY TO MOST FILE SYSTEM INTRINSICS.            *00056000
*                                                                      *00058000
*     X1   ENABLES CODE THAT CALLS SUDDENDEATH(50) WHEN IRRECOVERABLE  *00060000
*          ERRORS ARE DETECTED.  THESE ERRORS SHOULD NEVER OCCUR AND   *00062000
*          WOULD OTHERWISE GO UNDETECTED.                              *00064000
*                                                                      *00066000
*     X2   ENABLES CODE THAT CALLS SUDDENDEATH(50) WHEN DATA FAILS     *00068000
*          CREDIBLITY CHECKS.                                          *00070000
*                                                             *  +0.04  00072000
*     X3   ENABLES CODE THAT CALLS THE MMSTAT MEASUREMENT     *  +0.04  00074000
*          FACILITY FOR EACH INTRINSIC CALLED WHEN ACCESSING  *  +0.04  00076000
*          A DISC FILE.                                       *  +0.04  00078000
*                                                             *((00630))00080000
*     X9   ENABLES RELATIVE-I/O FEATURE (FOPEN/FOPENDA)       *((00630))00082000
*                                                                      *00084000
---------------------------------------------------------------------->>00086000
                                                                        00088000
$PAGE                                                          <<04558>>00090000
<<**********************************************************>> <<04558>>00092000
<<                                                          >> <<04558>>00094000
<<            LOCKING CONVENTIONS USED BY MODULE 97         >> <<04558>>00096000
<<                                                          >> <<04558>>00098000
<<     The follwing locking conventions used in module 97   >> <<04558>>00100000
<< are the accepted locking conventions and should be used  >. <<04558>>00102000
<< as described below.  The order and methods in which file >> <<04558>>00104000
<< system resources are obtained are as follows.            >> <<04558>>00106000
<<                                                          >> <<04558>>00108000
<< A. FMAVT SIR - currently this SIR is never locked in     >> <<04558>>00110000
<<    module 97.                                            >> <<04558>>00112000
<<                                                          >> <<04558>>00114000
<< B. ACB - The ACB is always obtained and locked via       >> <<04558>>00116000
<<    LOC'ACB.  LOC'ACB places a copy of the ACB in a       >> <<04558>>00118000
<<    Q-relative location of your choice and automatically  >> <<04558>>00120000
<<    locks the ACB if the file owns an LACB, signifying    >> <<04558>>00122000
<<    a mulitaccess file.  If the FMAVT SIR is obtained     >> <<04558>>00124000
<<    before calling LOC'ACB (it never is at present),      >> <<04558>>00126000
<<    then the FMAVT SIR must be sent as one of LOC'ACBs    >> <<04558>>00128000
<<    parameters so that if the process must impede on the  >> <<04558>>00130000
<<    ACB, the FMAVT SIR will be released for other proc-   >> <<04558>>00132000
<<    esses to use while the process requesting the lock    >> <<04558>>00134000
<<    impedes on the ACB.                                   >> <<04558>>00136000
<<                                                          >> <<04558>>00138000
<<    UNLOC'ACB is used to copy the PACB and LACB (if it    >> <<04558>>00140000
<<    exists) back into the data segment from which it      >> <<04558>>00142000
<<    came.  It also unlocks the ACB if it was previously   >> <<04558>>00144000
<<    locked by the process.                                >> <<04558>>00146000
<<                                                          >> <<04558>>00148000
<< C. Obtain FI SIR next.                                   >> <<04558>>00150000
<<                                                          >> <<04558>>00152000
<< D. FCB is locked via LOCK'CB.  LOCK'CB locks the FCB and >> <<04558>>00154000
<<    sets up the parameters for MDS instructions so that   >> <<04558>>00156000
<<    the FCB can be easily copied into the stack and back  >> <<04558>>00158000
<<    after it is changed.  It is the calling procedure's   >> <<04558>>00160000
<<    responsibility to update the FCB after it has been    >> <<04558>>00162000
<<    changed!  See the comment in the procedure heading of >> <<04558>>00164000
<<    LOCK'CB for more information about the "quick lock    >> <<04558>>00166000
<<    mode" and/or "conditional lock mode."                 >> <<04558>>00168000
<<                                                          >> <<04558>>00170000
<<    UNLOCK'CB unlocks the control block and un-impedes    >> <<04558>>00172000
<<    the next process waiting for the control block (if    >> <<04558>>00174000
<<    there is one).  Note:  no UNLOCK'CB is needed if the  >> <<04558>>00176000
<<    "quick lock" was successful, the process only needs   >> <<04558>>00178000
<<    to PSUEDO-ENABLE itself.                              >> <<04558>>00180000
<<                                                          >> <<04558>>00182000
<< These conventions must be adhered to so that deadlocks   >> <<04558>>00184000
<< can be avoided. Also, always make sure that there exists >> <<04558>>00186000
<< a corresponding unlock for every lock .  If a process    >> <<04558>>00188000
<< locks the same control block twice there must be two     >> <<04558>>00190000
<< corresponding unlocks for that control block.            >> <<04558>>00192000
<<**********************************************************>> <<04558>>00194000
                                                               <<04558>>00196000
$PAGE                                                          <<04558>>00198000
<< Correct problem in attempted write beyond FLIM >>           <<00532>>00200000
<< Add Relative I/O features >>                                <<00630>>00202000
<< Allow tape FOPEN without write ring. >>                     <<00685>>00204000
<< Fix EOT on unbuffered labeled tapes. >>                     <<00722>>00206000
<< Partially remove System Buffer code >>                      <<00822>>00208000
<< Add Tape Label info to FFILEINFO, etc. >>                   <<00828>>00210000
<< Change for 3270. >>                                         <<00838>>00212000
<< Labeled tape record and block size override FOPEN, FEQ. >>  <<00841>>00214000
<< FGETINFO can return "$NULL". >>                             <<00899>>00216000
<< FCONTROL write EOF to read-only tape rejected. >>           <<00900>>00218000
<< Correct FSPACE to labeled tape. >>                          <<00901>>00220000
<< Put all FCB's in system shared DST's. Fix SIR bug >>        <<01084>>00222000
<< Change test on initial extent alloc to <=0 >>               <<01084>>00224000
<< Initialize DX in FCONVBLK in case of error in LABELIOSQ. >> <<01085>>00226000
<< TEMPORARY fix for FCONTROL (2) and (6).                  >> <<01083>>00228000
<< Fix FGETINFO; chg FCLOSE to write EOF on mult.vol unlbl tp>><<01086>>00230000
<< Fast file system >>                                         <<*****>>00232000
<< Fix FLOCK/FUNLOCK to return error if device not disk >>     <<01672>>00234000
<< Fix IOWAIT, labeled tape, FDEVICECONTROL >>                 <<01698>>00236000
<< Fix :EOD, carriage control >>                               <<01720>>00238000
<< Fix FPOINT beyond EOF >>                                    <<01864>>00240000
<< Fix VIEW, priv file check, :EOD >>                          <<01790>>00242000
<< Add functions to FDEVICECONTROL >>                          <<01864>>00244000
<< Fix Break mode bug in UNLOCK'CB >>                          <<01898>>00246000
<< Fix extent initialization on FPOINT-WEOF >>                  <<1910>>00248000
<< Fix extent clear on WEOF >>                                 <<01936>>00250000
<< Fix variable file overflow >>                               <<01961>>00252000
<< Fix FUNLOCK to return correct errors (SR16944)            >><<02354>>00254000
<< Fix FFILEINFO of $NULL >>                                   <<02028>>00256000
<< fix FREADBACKWARD >>                                        <<02037>>00258000
<< Fix EOF recognition on variable files >>                    <<02049>>00260000
<< New Tape Labels code >>                                     <<02545>>00262000
<< Fix WEOF into unallocated extent >>                         <<02050>>00264000
<< FCONTROL: acc=APPEND: disallow rewind, fix write EOF      >><<02353>>00266000
<< Fix NOBUF FSPACE RIO >>                                     <<02054>>00268000
<< Fix bugs in FDEVICECONTROL and FCONTROL, add remote      >> <<02556>>00270000
<<   spoofle support to FDEVICECONTROL.                     >> <<02556>>00272000
<< Fix FREADBACKWARD >>                                        <<02068>>00274000
<< New error no. 74: No room left in stk seg for another file  <<02358>>00276000
<< Fix Report Recovered Tape Error >>                          <<02071>>00278000
<< Fix FREADBACKWARD and FSETMODE >>                           <<02076>>00280000
<< Oversize terminal writes now work in prespace mode.      >> <<02310>>00282000
<< Add support of variable density tape drives.             >> <<02570>>00284000
<< Add function code 140 to FDEVICECONTROL.                 >> <<02576>>00286000
<< Delete FCONTROL calls from FDEVICECONTROL.               >> <<02578>>00288000
<< Clean up Pre-read buffers on EOF >>                         <<03656>>00290000
<< Fix to convert to new disc free space management >>         <<03503>>00292000
<< Make sure FFILEINFO/FGETINFO return proper type/subtype.  >><<04161>>00294000
<< Add FSERR 6 and 7 for LINUS, chng NAVLSTAT for reel swt  >> <<03560>>00296000
<< Add FFILEINFO item 49 - PLABEL for soft int. (replaces   >> <<03657>>00298000
<< old item 47).                                            >> <<03657>>00300000
<< Fix FFILINFO item 43 to return blanks on non spool file  >> <<04611>>00302000
<< Add FDEVCNTL %213 and %220 for 2680G support.            >> <<04140>>00304000
<< Don't get FISIR in FCONV'BLK if file is opened EXC.      >> <<04160>>00306000
<< Add CIPER Phase I support to FDEVICECONTROL.             >> <<04321>>00308000
<< Fix problem created by fix 3656.  Dirty buffers when EOF>>  <<04250>>00310000
<<   hit on buffered read were not written to disk.        >>  <<04250>>00312000
<< Fix unitialized variablbe in FALTSEC.                   >>  <<04568>>00314000
<< Fix problem of clearing extents for ASCII RIO files     >>  <<04450>>00316000
<< Download entire VFC to 2608x printers.                   >> <<04482>>00318000
<< Make FGETPVINFO return -1 if file is remote.            >>  <<04877>>00320000
<< FSPACE now uses double arithmetic on NOBUF files.        >> <<04561>>00322000
<< Fixed NOBUF READ in IOMOVE, read past EOF when block not >> <<04557>>00324000
<< on sector boundries. (Not ACB'STREAMed)                  >> <<04557>>00326000
                                                                        00328000
DEFINE INT = INTEGER#,                                                  00330000
       DBL = DOUBLE#,                                          <<HM.00>>00332000
       LOG = LOGICAL#,                                                  00334000
       ABS = ABSOLUTE#,                                                 00336000
       ASMB = ASSEMBLE#;                                                00338000
DEFINE MOVE'DS'1 = ASSEMBLE(MDS 1)#;                                    00340000
DEFINE MOVE'DS'2 = ASSEMBLE(MDS 2)#;                                    00342000
DEFINE MOVE'DS'3 = ASSEMBLE(MDS 3)#;                                    00344000
DEFINE MOVE'DS'4 = ASSEMBLE(MDS 4)#;                                    00346000
DEFINE MOVE'DS'5 = ASSEMBLE(MDS 5)#;                                    00348000
DEFINE MOVE'DS'6 = ASSEMBLE(MDS 6)#;                                    00350000
INTEGER DB0 = DB+0;                                                     00352000
INTEGER DB1 = DB+1;                                                     00354000
INTEGER ARRAY ADB0 (*) = DB+0;                                          00356000
INTEGER ARRAY DUM (*) = DB+0;  << dummy reference param >>              00358000
DOUBLE ARRAY DADB0 (*) = DB+0;                                          00360000
INTEGER ARRAY AQM1 (*) = Q-1;                                           00362000
INTEGER ARRAY AQM2(*) = Q-2;                                            00364000
INTEGER ARRAY AQM3(*) = Q-3;                                            00366000
INTEGER ARRAY AQM4(*) = Q-4;                                            00368000
INTEGER ARRAY AQ0 (*) = Q-0;                                            00370000
INTEGER ARRAY AQPL0(*) = Q+0;                                           00372000
INTEGER ARRAY AQPL1(*) = Q+1;                                           00374000
INTEGER ARRAY AQPL2(*) = Q+2;                                           00376000
INTEGER ARRAY AQPL3(*) = Q+3;                                           00378000
INTEGER ARRAY AQPL4(*) = Q+4;                                           00380000
INTEGER ARRAY AQPL5(*) = Q+5;                                           00382000
INTEGER ARRAY AQPL6(*) = Q+6;                                           00384000
INTEGER ARRAY AQPL7(*) = Q+7;                                           00386000
INTEGER ARRAY AQPL8(*) = Q+8;                                           00388000
LOGICAL ARRAY LQ0(*) = Q+0;                                             00390000
DOUBLE  ARRAY DQ0(*) = Q+0;                                    <<04591>>00392000
BYTE BS0 = S-0;                                                         00394000
BYTE BS1 = S-1;                                                         00396000
BYTE BS2 = S-2;                                                         00398000
BYTE BS3 = S-3;                                                         00400000
INTEGER Q0 = Q-0;                                              <<00630>>00402000
INTEGER S0 = S-0;                                                       00404000
INTEGER S1 = S-1;                                                       00406000
INTEGER S2 = S-2;                                                       00408000
INTEGER S3 = S-3;                                                       00410000
INTEGER S4 = S-4;                                                       00412000
INTEGER S5 = S-5;                                                       00414000
INTEGER S6 = S-6;                                                       00416000
INTEGER S7 = S-7;                                                       00418000
LOGICAL LS0 = S-0;                                                      00420000
LOGICAL LS1 = S-1;                                                      00422000
LOGICAL LS2 = S-2;                                                      00424000
DOUBLE DS1 = S-1;                                                       00426000
DOUBLE DS2 = S-2;                                                       00428000
DOUBLE DS3 = S-3;                                                       00430000
DOUBLE DS4 = S-4;                                                       00432000
DOUBLE DS5 = S-5;                                                       00434000
DOUBLE DS6 = S-6;                                                       00436000
BYTE POINTER BPS0 = S-0;                                                00438000
BYTE POINTER BPS1 = S-1;                                                00440000
BYTE POINTER BPS2 = S-2;                                                00442000
BYTE POINTER BPS3 = S-3;                                       <<RV.PV>>00444000
INTEGER POINTER PS0 = S-0;                                              00446000
INTEGER POINTER PS1 = S-1;                                              00448000
INTEGER POINTER PS2 = S-2;                                              00450000
LOGICAL POINTER LPS0 = S-0;                                             00452000
LOGICAL POINTER LPS1 = S-1;                                             00454000
DOUBLE POINTER DPS0 = S-0;                                              00456000
DOUBLE POINTER DPS1 = S-1;                                              00458000
DOUBLE POINTER DPS2 = S-2;                                              00460000
DOUBLE POINTER DPS3 = S-3;                                              00462000
DOUBLE POINTER DPS4 = S-4;                                              00464000
DOUBLE POINTER DPS5 = S-5;                                              00466000
DOUBLE POINTER DPS6 = S-6;                                              00468000
DOUBLE POINTER DPS7 = S-7;                                              00470000
INTEGER ARRAY AS0 (*) = S-0;                                            00472000
INTEGER ARRAY AS1 (*) = S-1;                                            00474000
INTEGER ARRAY AS2 (*) = S-2;                                            00476000
INTEGER ARRAY AS3 (*) = S-3;                                            00478000
INTEGER ARRAY AS4 (*) = S-4;                                            00480000
INTEGER ARRAY AS5 (*) = S-5;                                   <<43.PV>>00482000
INTEGER DELTAQ =Q-0;                                                    00484000
LOGICAL STATUS =Q-1;                                                    00486000
INTEGER PREGISTER=Q-2;                                         <<03038>>00488000
INTEGER X = X;                                                          00490000
EQUATE CCE=2,CCG=0,CCL=1;                                               00492000
                                                                        00494000
DEFINE PRIVMODE = STATUS.(0:1)#,                                        00496000
      UMODE =STATUS.(0:1)&LSL(15)#,                                     00498000
       CARRYCODE = STATUS.(5:1)#,                                       00500000
       CONDCODE = STATUS.(6:2)#;                                        00502000
DEFINE ENABLE = ASSEMBLE(SED 1)#;                                       00504000
DEFINE DISABLE = ASSEMBLE(SED 0)#;                                      00506000
DEFINE PSEUDODISABLE = ASSEMBLE(PSDB)#;                                 00508000
DEFINE PSEUDOENABLE = ASSEMBLE(PSEB)#;                                  00510000
                                                               <<00822>>00512000
comment CHECKDB: If DB is at the stack, then DBBANK=SBANK.       00822  00514000
STACKDB and SBANK for the current process are obtained           00822  00516000
from the two words preceding the dispatcher marker on            00822  00518000
the interrupt control stack.  ;                                <<00822>>00520000
DEFINE CHECKDB =                                                        00522000
   DISABLE;                                                             00524000
   PUSH(DB);                                                            00526000
   X := ABSOLUTE(QI)-5;                                                 00528000
   TOS := ABSOLUTE(X);                                                  00530000
   X := X+1;                                                            00532000
   TOS := ABSOLUTE(X);                                                  00534000
   ENABLE;                                                              00536000
   ASSEMBLE(DCMP)#;                                                     00538000
DEFINE CURRENTDB = CHECKDB; TOS := IF = THEN 0 ELSE FSDSTX#;            00540000
DEFINE MPYD = ASSEMBLE(LDXA,LMPY;CAB,LDXA;MPY,ZERO;DADD)#,              00542000
       DIVD = ASSEMBLE(ZERO,CAB;LDXA,LDIV;CAB,LDXA;LDIV)#,              00544000
       DIVD'DEL = ASSEMBLE(ZERO,CAB;LDXA,LDIV;CAB,LDXA;LDIV,DEL)#;      00546000
                                                                        00548000
<<----------------------------------------------------------------------00550000
*                                                                      *00552000
*  File System Parameters                                              *00554000
*                                                                      *00556000
---------------------------------------------------------------------->>00558000
                                                                        00560000
EQUATE                                                                  00562000
MAXEXTENTS  =   32,   << maximum number of extents >>                   00564000
DEFEXTSIZE  =  256,   << default extent size >>                         00566000
DEFNUMEXTS  =    8,   << default number of extents >>                   00568000
DEFBUFFERS  =    2,   << default number of buffers >>          <<00.05>>00570000
MAXBUFFERS  = 8192,   << max. words of buffer space >>                  00572000
SPOOLRSIZE  =  506,   << default spoolfile rec size >>                  00574000
SPOOLRSECT  =    4,   << #sectors/spoolfile rec >>                      00576000
FISIR       =   37,   << File Integrity SIR number >>                   00578000
DSSIR       =    8;   << Directory SIR >>                               00580000
                                                                        00582000
<<----------------------------------------------------------------------00584000
*                                                                      *00586000
*  File Error Codes                                                    *00588000
*                                                                      *00590000
---------------------------------------------------------------------->>00592000
                                                                        00594000
EQUATE                                                                  00596000
SUCCESSFUL  =  0,   << NO ERRORS >>                            <<HM.00>>00598000
EOF         =  0,   << End Of File >>                                   00600000
ILLDB       =  1,   << illegal DB register >>                           00602000
ILLCAP      =  2,   << illegal capability >>                            00604000
OMITTEDPARM =  3,   << NEEDED PARAMETER IS MISSING >>          <<HM.00>>00606000
disc'space'allocation'disabled = 4,                            <<03503>>00608000
TOOBIGDRT   =  5,   << DRT number > 255 >>                     <<03052>>00610000
NO'SPARES   =  6,   << No available spare blocks on device. >> <<03560>>00612000
BLANK'MEDIA =  7,   << Unformatted or uninitialized media.  >> <<03560>>00614000
ILLPARM     =  8,   << illegal parameter value >>                       00616000
INVDRECSIZE = 10,   << invalid record size specification >>    <<RV.RV>>00618000
INVDBLKSIZE = 11,   << invalid resultant block size >>         <<RV.RV>>00620000
BADRECNO    = 12,   << record number out of range   >>         <<02068>>00622000
TOOMANYOPEN = 16,   << # FOPENs for a file > %377 >>           <<01898>>00624000
RUNAWAY     = 17,   << mag tape runaway >>                     <<01898>>00626000
DEVPWRUP    = 18,   << device powered up - reset >>            <<01898>>00630000
VFCRESET    = 19,   << LP VF control reset >>                  <<01898>>00632000
INVOP       = 20,   << invalid operation >>                             00634000
DATAPAR     = 21,   << data parity error >>                             00636000
SOFTIMEOUT  = 22,   << software timeout >>                              00638000
EOT         = 23,   << End Of Tape >>                                   00640000
NOTREADY    = 24,   << unit not ready >>                                00642000
NORING      = 25,   << no write ring >>                     <<NOT USED>>00644000
TRANSERR    = 26,   << transmission error >>                            00646000
IOTIMEOUT   = 27,   << I/O timeout >>                                   00648000
TIMERR      = 28,   << timing error or data overrun >>                  00650000
SIOFAIL     = 29,   << SIO failure >>                                   00652000
UNITFAIL    = 30,   << unit failure >>                                  00654000
EOL         = 31,   << End Of Line on special char >>                   00656000
SOFTABORT   = 32,   << software abort I/O >>                            00658000
DATALOST    = 33,   << data lost >>                                     00660000
UNITOFF     = 34,   << unit not on-line >>                              00662000
DATASET     = 35,   << data set not ready >>                            00664000
INVDISKADR  = 36,   << invalid disk address >>                          00666000
INVMEMADR   = 37,   << invalid memory address >>                        00668000
TAPERR      = 38,   << tape parity error >>                             00670000
TAPERREC    = 39,   << recovered tape I/O error >>                      00672000
ACCVIOL     = 40,   << access-type violation >>                         00674000
RECVIOL     = 41,   << record-type violation >>                         00676000
DEVVIOL     = 42,   << device-type violation >>                         00678000
BADTCOUNT   = 43,   << transfer count overrun on non-MR write >>        00680000
FUPDSEQERR  = 44,   << FUPDATE at record 0 >>                           00682000
PRIVVIOL    = 45,   << privileged-file violation >>                     00684000
NOSPACE     = 46,   << insufficient disk >>                             00686000
LBLIOERR    = 47,   << I/O error accessing file label >>                00688000
MLTIACCERR  = 48,   << invalid option due to multiple file access >>    00690000
UNIMPL      = 49,   << unimplemented function >>                        00692000
UNDEFACCT   = 50,   << undefined account >>                             00694000
UNDEFGRP    = 51,   << undefined group >>                               00696000
UNDEFFILESD = 52,   << file not found in system directory >>            00698000
UNDEFFILEJD = 53,   << file not found in job directory >>               00700000
INVFREF     = 54,   << invalid file reference >>                        00702000
NAVAILDEV   = 55,   << non-available device >>                          00704000
UNDEFDEV    = 56,   << undefined device >>                              00706000
MEMPROB     = 57,   << insufficient virtual memory >>                   00708000
NOPASSD     = 58,   << no passed file >>                                00710000
MTINTVIOL   = 59,   << standard label violation >>                      00712000
NORIN       = 60,   << no RIN available >>                              00714000
GPSPEX      = 61,   << group space exceeded >>                          00716000
ACSPEX      = 62,   << account space exceeded >>                        00718000
NONSHAR     = 63,   << user doesn't have Non-sharable Device cap. >>    00720000
MRIN        = 64,   << user doesn't have Multi-RIN cap. >>              00722000
PLIMIT      = 66,   << plotter limit switch reached >>                  00724000
PTAPERR     = 67,   << paper tape error >>                              00726000
SYSTEM      = 68,   << internal error >>                                00728000
UNUSED      = 69,   << unassigned ATTACHIO error >>                     00730000
IOERRHDR    = 70,   << header/trailer I/O error >>             <<01027>>00732000
                                                                        00734000
<< FS/CS common errors >>                                               00736000
                                                                        00738000
TMFP        = 71,   << too many files for process >>                    00740000
INVFN       = 72,   << invalid file number >>                           00742000
BNDVIOL     = 73,   << bounds violation >>                              00744000
NOROOMLEFT  = 74,   << no room for PXFILE expansion (for AFT)>><<02358>>00746000
BUFABSENT   = 76,   << input buffer absent (IOWAIT) >>         <<+1.01>>00748000
IOPENDING   = 77,   << No-wait I/O pending >>                           00750000
NOIOPENDING1= 78,   << no No-wait I/O pending for any file >>           00752000
NOIOPENDING2= 79,   << no No-wait I/O pending for spec. file >>         00754000
                                                                        00756000
<< Spooling error codes >>                                              00758000
                                                                        00760000
SPOOLMIN     = 80,  << smallest spooling error nr. >>                   00762000
SPOOLMAXSSECT= 80,  << max kilosectors used for spoolfiles >>           00764000
SPOOLNOCLASS = 81,  << spool class not defined >>                       00766000
SPOOLNOSPACE = 82,  << no space avail in spool class >>                 00768000
SPOOLBADEXT  = 83,  << extent size > 65K >>                             00770000
SPOOLDEVDOWN = 84,  << device in spool class down >>                    00772000
SPOOLILLOP   = 85,  << requ function inconsist with spooling >>         00774000
SPOOLERROR   = 86,  << spooling internal operational error >>           00776000
SPOOLBADOFF  = 87,  << offset to data > 255 >>                          00778000
SPOOLMAX     = 88,  << largest spooling error nr. >>                    00780000
                                                                        00782000
POWERFAILED = 89,   << power failed >>                                  00784000
EXSHERR1    = 90,   << exclusive violation - caller's req'ts >>         00786000
EXSHERR2    = 91,   << exclusive violation - other's req'ts >>          00788000
LWVIOL      = 92,   << lockword violation >>                            00790000
SEXVIOL     = 93,   << security violation >>                            00792000
USERIDVIOL  = 94,   << creator conflict >>                              00794000
BROKENREAD  = 95,   << "Broken" terminal Read >>                        00796000
DISCIOERR   = 96,   << misc. disc I/O error >>                          00798000
BADESCAPE   = 97,   << no CONTROL-Y PIN >>                              00800000
TIMEROVERFLOW=98,   << Read time overflow >>                            00802000
BOT         = 99,   << BOT and BSR or BSF request >>                    00804000
DUPNSD      =100,   << duplicate file name - system directory >>        00806000
DUPNJD      =101,   << duplicate file name - job directory >>           00808000
DIRIOERR    =102,   << directory I/O error >>                           00810000
DIROVFLO    =103,   << directory overflow - system directory >>         00812000
JTFDIROFL   =104,   << directory overflow - job directory >>            00814000
BADVARBLK   =105,   << bad variable block structure >>                  00816000
BADEXTENT   =106,   << extent size > 65K >>                             00818000
BADOFFSET   =107,   << Offset to data > 255 >>                          00820000
BADFILE     =108,   << inaccessable file - bad label >>                 00822000
BADCONTROL  =109,   << illegal carriage control >>                      00824000
INVSAVE     =110,   << attempt to save System file in Job directory >>  00826000
SFERR       =111,   << user lacks "Save File" capability >>    <<RV.PV>>00828000
UVCAP       =112,   << user lacks "Private Volume" capability ><<RV.PV>>00830000
MOUNTPROB   =113,   << volume set mount failure >>             <<RV.PV>>00832000
DISMOUNTPROB=114,   << volume set dismount failure >>          <<RV.PV>>00834000
HVSVIOL     =115,   << RENAME across HVS's violation >>        <<RV.PV>>00836000
LBTSYNTAX   =116,   << Syntax err in formsmsg >>               <<01898>>00838000
LBTUNEXP    =117,   << Tried write to unexpired tape >>        <<01898>>00840000
LBTFMTERR   =118,   << Format of "labeled" tape wrong >>       <<01898>>00842000
LBTPOSERR   =119,   << Error positioning labeled tape >>       <<01898>>00844000
<<>>                                                           <<01898>>00846000
LBTLWERR    =121,   << Labeled tape lockword violation >>      <<01898>>00848000
LBTOFLOW    =122,   << Tape label table overflow >>            <<01898>>00850000
LBTEOVSET   =123,   << End of volset encountered >>            <<01898>>00852000
LBTAPPEND   =124,   << Tried Append to labeled tape >>         <<01898>>00854000
ILL'CHAR'SET   = 126,   << FDEVCNT char set not btw 0 & 31. >> <<02556>>00856000
ILL'FORM       = 127,   << FDEVCNT form num not btw 0 & 31. >> <<02556>>00858000
ILL'LOG'PAGE   = 128,   << FDEVCNT lpage num <> 0 to 31.    >> <<02556>>00860000
ILL'VFC        = 129,   << FDEVCNT vert fmt num <> 0 to 31. >> <<02556>>00862000
ILL'NUMCOPIES  = 130,   << FDEVCNT num copies <> 1 to 32767 >> <<02556>>00864000
ILL'OVERLAY    = 131,   << FDEVCNT num overlays <> 1 to 8.  >> <<02556>>00866000
ILL'PAGELENGTH = 132,   << FDEVCNT pg lngth parm <> 12-68.  >> <<02556>>00868000
ILL'PICTURE    = 133,   << FDEVCNT pict num <> 0 to 31      >> <<04140>>00870000
SET'OR'CLEAR   = 134,   << FDEVCNT P1 must be 1 or 0.       >> <<04321>>00872000
DLTDREC     =139,   << deleted record on IBM floppy disc >>    <<01898>>00874000
INACT       =148,   << inactive RIO record (CCE) >>            <<00630>>00876000
NONPAIR     =149,   << unmatched FFILEINFO ITEMNUM/VAL >>      <<00630>>00878000
NONITEM     =150,   << undefined FFILEINFO ITEMNUM >>          <<01898>>00880000
FILETYPEVIOL=151;   << undefined file type >>                  <<01898>>00882000
                                                                        00884000
EQUATE DUPKEY       =171;<< duplicate key >>                   <<01898>>00886000
EQUATE ERRNOKEY     =172;<< no such key >>                     <<KS.00>>00888000
EQUATE ERRTCOUNTL   =173;<< TCOUNT longer than RECSIZE >>      <<KS.00>>00890000
EQUATE ERRNOEXTRADS =174;<< can't get extra data segment >>    <<KS.00>>00892000
EQUATE KSAMERROR    =175;<< KSAM internal error >>             <<KS.00>>00894000
EQUATE ILLENGTH     =176;<< illegal extra data seg length >>   <<KS.00>>00896000
EQUATE TOOMANYDS    =177;<< too many extra data segs >>        <<KS.00>>00898000
EQUATE NODSSTORAGE  =178;<< no storage for extra data seg >>   <<KS.00>>00900000
EQUATE NOTLOCKED    =179;<<file not locked: must FLOCK first>> <<02354>>00902000
EQUATE ILLKEYLOC    =181;<< illegal KEYLOC parameter >>        <<KS.00>>00904000
EQUATE EMPFIL       =182;<< file is empty >>                   <<KS.00>>00906000
EQUATE RECTOOSHORT  =183;<< record doesn't contain all keys >> <<KS.00>>00908000
EQUATE NEGNUMBER    =184;<< negative number in FFINDN >>       <<KS.00>>00910000
EQUATE SEQERROR     =185;<< sequence error on primary key >>   <<KS.00>>00912000
EQUATE KEYTOOSHORT  =186;<< generic key not OK for numeric >>  <<KS.00>>00914000
                         << display or packed decimal >>       <<KS.00>>00916000
EQUATE INVKSPEC     =187;<< invalid key specification >>       <<KS.00>>00918000
EQUATE INVDEV       =188;<< invalid device specification >>    <<KS.00>>00920000
EQUATE INVRECFMT    =189;<< invalid record format >>           <<KS.00>>00922000
EQUATE INVKBF       =190;<< invalid keyblock factor >>         <<KS.00>>00924000
DEFINE SPOOLERRCODE = IF S0<>0 AND INTEGER(SPOOLF)<0 AND       <<04143>>00928000
                         NOT(SPOOLMIN<=S0<=SPOOLMAX) THEN               00930000
                         BEGIN DEL; TOS := SPOOLERROR; END #;           00932000
                                                                        00934000
<<----------------------------------------------------------------------00936000
*                                                                      *00938000
*  File System Monitoring definitions                                  *00940000
*                                                                      *00942000
---------------------------------------------------------------------->>00944000
                                                                        00946000
DEFINE                                                                  00948000
MYPIN         = (ABS(MONITOR).(0:8) = 0 OR                              00950000
                 ABS(MONITOR).(0:8) = GETPROCNUM)#,                     00952000
                                                                        00954000
MONOTHER      = INTEGER(ABSOLUTE(MONITOR)) <> 0 AND            <<+1.C3>>00956000
                ABS(MONITOR).(13:1) AND MYPIN#,<<OTHER>>       <<+1.C3>>00958000
MONUNCALLABLE = INTEGER(ABSOLUTE(MONITOR)) <> 0 AND            <<+1.C3>>00960000
                ABS(MONITOR).(14:1) AND MYPIN#,<<UNCALLABLE>>  <<+1.C3>>00962000
MONCALLABLE   = INTEGER(ABSOLUTE(MONITOR)) <>0 AND             <<+1.C3>>00964000
                ABS(MONITOR).(15:1) AND MYPIN#;<<CALLABLE>>    <<+1.C3>>00966000
                                                               <<+0.04>>00968000
<<-------------------------------------------------------------  +0.04  00970000
*                                                             *  +0.04  00972000
*  MMSTAT measurement definitions                             *  +0.04  00974000
*                                                             *  +0.04  00976000
---------------------------------------------------------------  +0.04>>00978000
                                                               <<+0.04>>00980000
DEFINE MEAS'TAPE'ON =LOGICAL(ABSOLUTE(MEASMSK1))#;             <<+1.C3>>00982000
EQUATE                                                         <<+0.04>>00984000
EFOPEN          = -60,  << FOPEN/FOPENDA initial >>            <<+0.04>>00986000
EFOPEN'         = -61,  << FOPEN/FOPENDA continuation >>       <<+0.04>>00988000
EFREAD          = -62,  << FREAD >>                            <<+0.04>>00990000
EFWRITE         = -63,  << FWRITE >>                           <<+0.04>>00992000
EFREADDIR       = -64,  << FREADDIR initial >>                 <<+0.04>>00994000
EFREADDIR'      = -64,  << FREADDIR continuation >>            <<+0.04>>00996000
EFWRITEDIR      = -65,  << FWRITEDIR initial >>                <<+0.04>>00998000
EFWRITEDIR'     = -65,  << FWRITEDIR continuation >>           <<+0.04>>01000000
EFUPDATE        = -66,  << FUPDATE >>                          <<+0.04>>01002000
EIOWAIT         = -67,  << IOWAIT >>                           <<+0.04>>01004000
EFREADSEEK      = -68,  << FREADSEEK >>                        <<+0.04>>01006000
EFSPACE         = -69,  << FSPACE >>                           <<+0.04>>01008000
EFPOINT         = -70,  << FPOINT >>                           <<+0.04>>01010000
EFCONTROL       = -71,  << FCONTROL >>                         <<+0.04>>01012000
EFSETMODE       = -72,  << FSETMODE >>                         <<+0.04>>01014000
EFRELATE        = -73,  << FRELATE >>                          <<+0.04>>01016000
EFCHECK         = -74,  << FCHECK >>                           <<+0.04>>01018000
EFGETINFO       = -75,  << FGETINFO >>                         <<+0.04>>01020000
EFREADLABEL     = -76,  << FREADLABEL >>                       <<+0.04>>01022000
EFWRITELABEL    = -77,  << FWRITELABEL >>                      <<+0.04>>01024000
EFLOCK          = -78,  << FLOCK >>                            <<+0.04>>01026000
EFUNLOCK        = -79,  << FUNLOCK >>                          <<+0.04>>01028000
EFRENAME        = -80,  << FRENAME >>                          <<+0.04>>01030000
EFCLOSE         = -81,  << FCLOSE >>                           <<+0.04>>01032000
EFALTSEC        = -82;  << FALTSEC >>                          <<01175>>01034000
                                                                        01036000
<<----------------------------------------------------------------------01038000
*                                                                      *01040000
*  SYSGLOB definitions                                                 *01042000
*                                                                      *01044000
---------------------------------------------------------------------->>01046000
                                                                        01048000
EQUATE                                                                  01050000
DSTP         =   2,         << DST base >>                              01052000
QI           =   5,                                                     01054000
SYSDB        = 512,         << System DB base >>                        01056000
CLOADID      = SYSDB+%75,   << Cold Load count >>                       01058000
SHFCBDST     = SYSDB+%76,   << Shared FCB DST nr. >>                    01060000
MONITOR      = SYSDB+%77,   << monitoring flag word >>                  01062000
MAXSSECT     = SYSDB+%100,  << max # spoolfile sectors >>               01064000
NUMSSECT     = SYSDB+%102,  << current # ...........   >>               01066000
EXTSSECT     = SYSDB+%104,  << # sectors/spoolfile extent >>            01068000
SPOOLINDEX   = SYSDB+%132,  << class spool index >>                     01070000
CSIOWAIT     = SYSDB+%135,  << CSIOWAIT P-label >>                      01072000
CCLOSEPLABL  = SYSDB+%140,  << CS CCLOSE Plabel - FPROCTERM >>          01074000
MEASMSK1     = SYSDB+%267,                                     <<+1.C3>>01076000
DSCHKPLABL   = SYSDB+%335,  << DSCHECK Plabel >>               <<DS.00>>01078000
DSOPENPLABL  = SYSDB+%336,  << DSOPEN Plabel >>                <<DS.00>>01080000
DSCLOSEPLABL = SYSDB+%337,  << DSCLOSE Plabel >>               <<DS.00>>01082000
SDSLDEVLABEL = SYSDB+%323,  << Plabel for SDSLDEV >>           <<DS.04>>01084000
EXTLAB3270   = %73,         << SYSGLOBEXT index >>             <<01165>>01086000
SYSEXTPTR    = %377,        << ptr to SYSEXT of SYSGLOB >>     <<01165>>01088000
MANWCPLABL   = SYSDB+%340,  << MANAGEWRITECONV Plabel >>       <<DS.00>>01090000
AVR          = SYSDB+%346;  << Auto Vol Recognition - tape labels >>    01092000
POINTER SYSGLOBEXT = SYSEXTPTR;                                <<01165>>01094000
DEFINE                                                         <<01165>>01096000
  PLABEL3270 = SYSGLOBEXT(EXTLAB3270)#;                        <<01165>>01098000
INTEGER POINTER DST' = DSTP;                                            01100000
                                                                        01102000
<<----------------------------------------------------------------------01104000
*                                                                      *01106000
*  Job Info Table (JIT) definitions                                    *01108000
*                                                                      *01110000
---------------------------------------------------------------------->>01112000
                                                                        01114000
EQUATE                                                                  01116000
JCELLS      =  2,   << JMAT offset to JCELLS ptr >>                     01118000
JITJNUM     =  9,   << Job number >>                                    01120000
JITMPN      = 10,   << Main program PIN in (8:8) >>                     01122000
JITEOF      = 11,   << EOF flush flags >>                               01124000
JITASEC     = 13,   << Acct security >>                                 01126000
JITHAN      = 16,   << word index in JIT for Home Account  >>           01128000
JITAIP      = 32,   << word index in JIT for Acct Directory index >>    01130000
JITGIP      = 33,   << word index in JIT for Grp Directory index >>     01132000
JITPFP      = 18,   << passed file double pointer >>                    01134000
JITJN       = 44,   << Job name >>                                      01136000
JPASS       = 14;   << JCELLS double offset to Pass cells >>            01138000
                                                                        01140000
<<----------------------------------------------------------------------01142000
*                                                                      *01144000
*  I/O System definitions                                              *01146000
*                                                                      *01148000
---------------------------------------------------------------------->>01150000
                                                                        01152000
EQUATE   << Device type (subtype) & subclass >>                <<02560>>01154000
MHDISK       =  0,    DIRACC     =  0,                                  01156000
FHDISK       =  1,                                                      01158000
FDISC        =  7,                                             <<01115>>01160000
CARDR        =  8,    SERIALIN   =  1,                                  01162000
PTREAD       =  9,                                                      01164000
TERMINAL     = 16,    PARALELL   =  2,                                  01166000
READERPUNCH  = 20,                                                      01168000
SSLC         = 22,                                                      01170000
PROGCONT     = 23,                                                      01172000
MTAPE        = 24,    SERIALIO   =  3,                                  01174000
   HP7970    =  0,    << subtype.(13:3) = 0 >>                 <<02560>>01176000
   HP7976    =  1,    << subtype.(13:3) = 1 >>                 <<02560>>01178000
SDISC        = 31,                                             <<00.SD>>01180000
LPTR         = 32,    SERIALOUT  =  4,                                  01182000
CPNCH        = 33,                                                      01184000
PTPNCH       = 34,                                                      01186000
CALCOMP500   = 35,                                                      01188000
CALCOMP600   = 36,                                                      01190000
CALCOMP700   = 37,                                                      01192000
CALCOMP836   = 38,                                                      01194000
NULL         = 63;                                                      01196000
                                                                        01198000
DEFINE S1STAT         = S1.(8:8)#,                             <<04321>>01200000
       GENERAL'STATUS = (13:3)#;                               <<04321>>01202000
                                                               <<04321>>01204000
EQUATE   << IOCODE VALUES >>                                            01206000
EOFSTAT     = %12,                                                      01208000
EOTSTAT     = %31,                                                      01210000
NAVLSTAT    =%204,    << device not available after reelswt >> <<03560>>01212000
NO'ERR'STAT =   1,   << Normal return from ATTACHIO.        >> <<04321>>01214000
BREAKSTAT   =%173,   << BREAK hit on terminal >>                        01216000
PARERRSTAT  = %74,   << tape parity error >>                   <<02068>>01218000
EOFCODE     =  2;                                                       01220000
                                                               <<+0.05>>01222000
DEFINE  << ATTACHIO FLAGS >>                                   <<+0.05>>01224000
UFLAGS    = %010000#,  << unblocked >>                         <<+0.05>>01226000
BFLAGS    = %010001#;  << blocked >>                           <<+0.05>>01228000
                                                                        01230000
<<----------------------------------------------------------------------01232000
*                                                                      *01234000
*  Logical Physical Device Table (LPDT) definitions                    *01236000
*                                                                      *01238000
---------------------------------------------------------------------->>01240000
                                                                        01242000
DEFINE                                                         <<04321>>01244000
  LPDTENTRY = LPDT(0).(8:8)#;   << LPDT entry size.         >> <<04321>>01248000
                                                                        01250000
LOGICAL POINTER LPDT = 8;  << LPDT system table >>             <<02545>>01252000
DEFINE LPDT'BOT = LPDT(LOGICAL(LDEV)*LPDTENTRY + 1).(4:1)#;    <<04321>>01254000
                                                                        01256000
<<----------------------------------------------------------------------01258000
*                                                                      *01260000
*  Logical Device Table (LDT) definitions                              *01262000
*                                                                      *01264000
---------------------------------------------------------------------->>01266000
                                                                        01268000
EQUATE                                                                  01270000
LDT         = %16,  << Logical Device Table DST >>                      01272000
LDTENTRY    =   5,  << entry size >>                                    01274000
LDTSIR      = %12,  << Table sir >>                            <<02560>>01276000
DENSITYW    =   4,  << Entry offset for density info >>        <<02560>>01278000
LDTNO       =   3;                                                      01280000
DEFINE  CS = (8:1)#;  <<CS device >>                           <<00161>>01282000
DEFINE                                                         <<02560>>01284000
   << Density definitions for LDT entry >>                     <<02560>>01286000
   TAPE'DENSITY    = LDT'DENW.(1:3)#, << Actual tape den. >>   <<02560>>01288000
   REQUEST'DENSITY = LDT'DENW.(4:3)#; << User requested den. >><<02560>>01290000
EQUATE                                                         <<02560>>01292000
   << Possible values for density field. >>                    <<02560>>01294000
   DEN'1600 = 1,                                               <<02560>>01296000
   DEN'6250 = 2;                                               <<02560>>01298000
                                                                        01300000
<<----------------------------------------------------------------------01302000
*                                                                      *01304000
*  Process Control Block (PCB) definitions                             *01306000
*                                                                      *01308000
---------------------------------------------------------------------->>01310000
                                                                        01312000
EQUATE                                                                  01314000
DSTENTRY    =   4,  << Size of a DST entry in words.        >> <<04776>>01316000
USER'MAIN   =   2,  << CI PCB type >>                          <<DS.06>>01318000
PCBB        =   3,  << PCB base >>                                      01320000
CPCB        =   4,  << current PCB >>                                   01322000
PORTWAKE    =   4,  << PORT WAKE BIT>>                         <<HM.00>>01324000
PCBSIZE     =  16;  << PCB size - words >>                              01326000
                                                                        01328000
DEFINE                                                                  01330000
GETPROCNUM  = (ABSOLUTE(CPCB)-ABSOLUTE(PCBB))&LSR(4)#;                  01332000
                                                                        01334000
INTEGER POINTER PCB = 3;  << PCB system table >>                        01336000
                                                                        01338000
DEFINE                                                                  01340000
PCBXDS      = PCB(PIN*PCBSIZE+2).(1:10)#,  <<extra data seg. nr.>>      01342000
PCBSTK      = PCB(PIN*PCBSIZE+3).(1:10)#,  <<stack DST nr.>>            01344000
PCBIQPTR    = PCB(PIN*PCBSIZE+8).(8:8)#,   <<impeded queue pointer>>    01346000
PCBPTYPE    = PCB(PIN*PCBSIZE+9).(6:2)#,   <<process type>>             01348000
PCBFATHER    =  PCB(PIN*PCBSIZE+5).(0:8)#,                     <<DS.06>>01350000
PCBTYPE      =  PCB(PIN*PCBSIZE+9).(6:3)#,                     <<DS.06>>01352000
                                                                        01354000
PCB'XDS     = ABS(ABS(CPCB)+2).(1:10)#,    <<extra data seg. nr.>>      01356000
PCB'STK     = ABS(ABS(CPCB)+3).(1:10)#,    <<stack DST nr.>>            01358000
PCB'IQPTR   = ABS(ABS(CPCB)+8).(8:8)#,     <<Impeded queue pointer>>    01360000
PCB'PTYPE   = ABS(ABS(CPCB)+9).(6:2)#;     <<process type>>             01362000
                                                                        01364000
<<----------------------------------------------------------------------01368000
*                                                                      *01370000
*  PXGLOB definitions                                                  *01372000
*                                                                      *01374000
---------------------------------------------------------------------->>01376000
                                                                        01378000
DEFINE                                                                  01380000
FINDPCBX    = PUSH(DL); TOS := TOS-PS0(-1)#,                            01382000
SETPCBX     = FINDPCBX; @PCBX := TOS#,                                  01384000
DBOFFSET    = FINDPCBX; TOS := PS0(1); DELB#;                           01386000
                                                                        01388000
DEFINE                                                                  01390000
PXGSTDIN    = PCBX(3).(8:8)#,  << $STDIN logical device nr. >>          01392000
PXGSTDLIST  = PCBX(4).(8:8)#,  << $STDLIST logical device nr. >>        01394000
PXGJOBTYPE  = PCBX(6).(2:2)#,  << Job type >>                           01396000
PXGJITDST   = PCBX(6).(6:10)#; << JIT DST nr. >>                        01398000
                                                                        01400000
<<----------------------------------------------------------------------01402000
*                                                                      *01404000
*  AOPTIONS DEFINITIONS                                                *01406000
*                                                                      *01408000
---------------------------------------------------------------------->>01410000
                                                                        01412000
DEFINE  <<AOPTION fields>>                                              01414000
AOPCOPYF        = (3:1)#,                << COPY MODE >>       <<HM.00>>01416000
AOPNOWAITF      = (4:1)#,                << No-Wait I/O mode >>         01418000
AOPMULTACF      = (5:2)#,                << Multi-access mode >>        01420000
AOPINHIBITBUFF  = (7:1)#,                << inhibit buffering >>        01422000
AOPACMODEF      = (8:2)#,                << access mode >>              01424000
AOPLOCKINGF     = (10:1)#,               << dynamic locking >>          01426000
AOPMULTIRECF    = (11:1)#,               << multi-record >>             01428000
AOPACTYPEF      = (12:4)#;               << access type >>              01430000
                                                                        01432000
DEFINE                                                                  01434000
AOPCOPY         = AOPTIONS.(3:1)#,       << FILE TO BE COPIED>><<HM.00>>01436000
AOPNOWAIT       = AOPTIONS.(4:1)#,       << No-Wait I/O mode >>         01438000
AOPMULTAC       = AOPTIONS.(5:2)#,       << multi-access mode >>        01440000
AOPGLOBALMULTAC = AOPTIONS.(5:1)#,       << INTER JOB MULTI>>  <<HM.00>>01442000
AOPINHIBITBUF   = AOPTIONS.(7:1)#,       << inhibit buffering >>        01444000
AOPACMODE       = AOPTIONS.(8:2)#,       << access mode >>              01446000
AOPDEFAULT      = (INT(AOPACMODE) = 0)#, << default >>                  01448000
AOPEXCLUSIVE    = (INT(AOPACMODE) = 1)#, << exclusive >>                01450000
AOPSEMI         = (INT(AOPACMODE) = 2)#, << semi-exclusive >>           01452000
AOPSHARE        = (INT(AOPACMODE) = 3)#, << share >>                    01454000
AOPLOCKING      = AOPTIONS.(10:1)#,      << dynamic locking >>          01456000
AOPMULTIREC     = AOPTIONS.(11:1)#,      << multi-record >>             01458000
AOPACTYPE       = AOPTIONS.(12:4)#,      << access type >>              01460000
AOPREAD         = (INT(AOPACTYPE) = 0)#, << read only >>                01462000
AOPWRITE        = (INT(AOPACTYPE) = 1)#, << write only - delete >>      01464000
AOPWRITESAVE    = (INT(AOPACTYPE) = 2)#, << write only - save >>        01466000
AOPAPPEND       = (INT(AOPACTYPE) = 3)#, << append only >>              01468000
AOPREADWRITE    = (INT(AOPACTYPE) = 4)#, << read or write >>            01470000
AOPUPDATE       = (INT(AOPACTYPE) = 5)#, << update only >>              01472000
AOPEXECUTE      = (INT(AOPACTYPE) = 6)#, << execute only >>             01474000
AOPWRITEONLY    = (1 <= INT(AOPACTYPE) <= 3)#;  << form of write >>     01476000
                                                                        01478000
<<----------------------------------------------------------------------01480000
*                                                                      *01482000
*  FOPTIONS DEFINITIONS                                                *01484000
*                                                                      *01486000
---------------------------------------------------------------------->>01488000
                                                                        01490000
DEFINE  <<FOPTIONS fields>>                                             01492000
FILETYPE      = (2:3)#,                << TYPE OF FILE >>      <<HM.00>>01494000
FOPNOEQUATEF  = (5:1)#,                << no file equation >>           01496000
FOPLABELLEDF  = (6:1)#,                << labelled tape >>              01498000
FOPCONTROLF   = (7:1)#,                << carriage control >>           01500000
FOPFORMATF    = (8:2)#,                << record format >>              01502000
FOPDESIGNATORF= (10:3)#,               << designator type >>            01504000
FOPASCIIF     = (13:1)#,               << ASCII format >>               01506000
FOPDOMAINF    = (14:2)#;               << file domain >>                01508000
                                                                        01510000
DEFINE                                                                  01512000
FOPFILETYPE   = FOPTIONS.(2:3)#,         << TYPE OF FILE >>    <<HM.00>>01514000
FOPKSAM       = (FOPFILETYPE=1)#,      << RESERVED FOR KSAM >> <<HM.00>>01516000
FOPRIO        = (FOPFILETYPE=2)#,      << RIO FILE >>          <<HM.00>>01518000
FOPCIRFILE    = (FOPFILETYPE=4)#,      << CIRCULAR FILE >>     <<HM.00>>01520000
FOPMSGFILE    = (FOPFILETYPE=6)#,      << IPC FILE >>          <<HM.00>>01522000
FOPNOEQUATE   = FOPTIONS.(5:1)#,       << no file equation >>           01524000
FOPLABELLED   = LOG(FOPTIONS.(6:1))#,                        <<TL.02>>  01526000
FOPCONTROL    = FOPTIONS.(7:1)#,       << carriage control >>           01528000
FOPFORMAT     = FOPTIONS.(8:2)#,       << record format >>              01530000
FOPVARFLD     = FOPTIONS.(9:1)#,       << variable bit >>               01532000
FOPFIXED      = (INT(FOPFORMAT) = 0)#, << fixed >>                      01534000
FOPVARIABLE   = (INT(FOPVARFLD) = 1)#, << variable >>                   01536000
FOPNORMVAR    = (INT(FOPFORMAT) = 1)#, << normal variable >>            01538000
FOPSPECVAR    = (INT(FOPFORMAT) = 3)#, << special variable >>           01540000
FOPUNDEFINED  = (INT(FOPFORMAT) = 2)#, << undefined >>                  01542000
FOPFIXEDFMT   = 0  #,                                        <<01115>>  01544000
FOPDESIGNATOR = FOPTIONS.(10:3)#,      << designator type >>            01546000
FOPACTUAL     = (INT(FOPDESIGNATOR) = 0)#,<< actual >>                  01548000
FOPSTDLIST    = (INT(FOPDESIGNATOR) = 1)#,<< $STDLIST >>                01550000
FOPNEWPASS    = (INT(FOPDESIGNATOR) = 2)#,<< $NEWPASS >>                01552000
FOPOLDPASS    = (INT(FOPDESIGNATOR) = 3)#,<< $OLDPASS >>                01554000
FOPSTDIN      = (INT(FOPDESIGNATOR) = 4)#,<< $STDIN >>                  01556000
FOPSTDINX     = (INT(FOPDESIGNATOR) = 5)#,<< $STDINX >>                 01558000
FOPNULL       = (INT(FOPDESIGNATOR) = 6)#,<< $NULL >>                   01560000
FOPASCII      = FOPTIONS.(13:1)#,      << ASCII format >>               01562000
FOPDOMAIN     = FOPTIONS.(14:2)#,      << file domain >>                01564000
FOPNEW        = (INT(FOPDOMAIN) = 0)#, << new >>                        01566000
FOPPERMANENT  = (INT(FOPDOMAIN) = 1)#, << old - permanent >>            01568000
FOPTEMPORARY  = (INT(FOPDOMAIN) = 2)#, << old - temporary >>            01570000
FOPOLD        = (INT(FOPDOMAIN) = 3)#; << old - either >>               01572000
                                                                        01574000
                                                                        01576000
<<----------------------------------------------------------------------01578000
*                                                                      *01580000
*  FOPEN State Word (STATE) definitions                                *01582000
*                                                                      *01584000
---------------------------------------------------------------------->>01586000
                                                                        01588000
DEFINE                                                                  01590000
CARRIAGEF   = (9:1)#,         << carriage control flag >>               01592000
READCODE    = (11:4)#,        << input EOF check >>                     01594000
READTYPE    = (11:2)#,        << 00 Data,01 Job,10 Sess >>              01596000
READMODE    = (13:2)#;        << see below >>                           01598000
                                                                        01600000
EQUATE                                                                  01602000
STDINRD     = 0,    << type=Job/Session >>                              01604000
STDINXRD    = 1,                                                        01606000
STDINCIRD   = 2,                                                        01608000
MAGTRD      = 0,    << type=Data >>                                     01610000
OTHERRD     = 1,                                                        01612000
COLONRD     = 2;                                                        01614000
                                                                        01616000
<<----------------------------------------------------------------------01618000
*                                                                      *01620000
*  PCBX File Section (PXFILE) definitions                              *01622000
*                                                                      *01624000
---------------------------------------------------------------------->>01626000
                                                                        01628000
DEFINE                                                                  01630000
FINDPXFILE      = PUSH(DL); TOS := TOS-PS0(-3)#,                        01632000
SETPXFILE       = FINDPXFILE; @PXFILE := TOS#;                          01634000
                                                                        01636000
EQUATE                                                                  01638000
PXFCBTMAX   = 8,            << max. nr. user (NOBUF) CBT's >>           01640000
PXFOVERHEAD = 8+PXFCBTMAX,  << PXFILE overhead size in words >>         01642000
PXFCBTSIZEMAX=1000;         << max. PXFILE size >>                      01644000
                                                                        01646000
DEFINE                                                                  01648000
PXFSIZE     = PXFILE#,         << PXFILE size >>                        01650000
PXFDOPEN    = PXFILE(1).(0:8)#,<< last DOPEN error code >>              01652000
PXFCOPEN    = PXFILE(1).(8:8)#,<< last COPEN error code >>              01654000
PXFNOCB     = LOG(PXFILE(2).(0:1))#,  << no CB's in PCBX? >>            01656000
PXFDSINFO   = PXFILE(3)#,      << reserved for DS >>                    01658000
PXFKOPEN    = PXFILE(4).(0:8)#,<< reserved for KSAM >>                  01660000
PXFFOPEN    = PXFILE(4).(8:8)#,<< last FOPEN error code >>              01662000
PXFAFTSIZE  = PXFILE(5)#,      << AFT size in words >>                  01664000
PXFCTRINFO  = PXFILE(6)#,      << CS trace file info >>                 01666000
PXFLEFTOFF  = PXFILE(7)#,      << last responding file/line >>          01668000
PXFCBT1     = PXFILE(8)#,      << 1st user (NOBUF) CBT DST nr. >>       01670000
PXFCBTAB    = PXFILE(16)#,     << control block table >>                01672000
PXFCBTSIZE  = PXFILE(16)#,     << C.B. table size in words >>           01674000
PXFDSTX     = PXFILE(17)#,     << C.B. table DST number >>              01676000
PXFVTSIZE   = PXFILE(18)#,     << vector table size in words >>         01678000
PXFLOCK     = PXFILE(19)#,     << C.B. table lock word >>               01680000
PXFQUEUE    = PXFILE(20)#,     << C.B. table impede word >>             01682000
PXFVT       = PXFILE(21)#;     << vector table >>                       01684000
                                                                        01686000
<<----------------------------------------------------------------------01688000
*                                                                      *01690000
*  Data Segment CBT definitions                                        *01692000
*                                                                      *01694000
---------------------------------------------------------------------->>01696000
                                                                        01698000
EQUATE                                                                  01700000
FSEGINIT    = 720,  << DST CBT initial size - no buffers >>             01702000
FSEGMAX     = 5120, << DST CBT maximum size - no buffers >>    <<00.06>>01704000
FSEGBUFMAX  = 8192, << DST CBT maximun size - buffers >>                01706000
FSOVERHEAD  = 5,    << DST CBT overhead size in words >>                01708000
FSVTENTRY   = 4;    << CBT vector table entry size >>                   01710000
                                                                        01712000
INTEGER ARRAY FSCBTAB (*) = DB+0;  << F.S. control block table >>       01714000
INTEGER FSSIZE = DB+0;         << F.S. table size in words >>           01716000
INTEGER FSDSTX = DB+1;         << F.S. table DST number >>              01718000
INTEGER FSVTSIZE = DB+2;       << vector table size in words >>         01720000
INTEGER FSLOCK = DB+3;         << F.S. table lock word >>               01722000
INTEGER FSQUEUE = DB+4;        << F.S. table impeded queue >>           01724000
ARRAY FSVT(*) = DB+FSOVERHEAD; << vector table >>              <<+1.03>>01726000
                                                                        01728000
DEFINE                                                                  01730000
FSDSTSIZE = (ABSOLUTE(ABSOLUTE(DSTP)+FSDSTX&LSL(2)).(3:13)-1)&LSL(2)#;  01732000
                                                                        01734000
<<----------------------------------------------------------------------01736000
*                                                                      *01738000
*  Control Block Table (CBTAB) definitions                             *01740000
*                                                                      *01742000
---------------------------------------------------------------------->>01744000
                                                                        01746000
EQUATE                                                                  01748000
VTENTRY     = 4,           << Size of Vector Table Entry.   >> <<04776>>01750000
CBTOVERHEAD = FSOVERHEAD,  << CB Table overhead size in words >>        01752000
CBTVT1      = 16,          << nr. init. VT entries - PXFILE >>          01754000
CBTVT2      = 64,          << nr. init. VT entries - user >>            01756000
CBTVT3      = 64,          << nr. init. VT entries - system >>          01758000
CBTVT4      = 1;           << nr. init. VT entries - buf. ACB >>        01760000
                                                                        01762000
                                                                        01764000
EQUATE                                                                  01766000
CBGARBAGE   = 0,  << garbage type nr. >>                                01768000
CBFCB       = 1,  << FCB type nr. >>                                    01770000
CBPACB      = 2,  << PACB type nr. >>                                   01772000
CBLACB      = 3;  << LACB type nr. >>                                   01774000
                                                                        01776000
DEFINE                                                                  01778000
CBDESCRIP   = CB#,            << descriptor word >>                     01780000
CBTYPE      = CB.(0:2)#,      << control block type nr. >>              01782000
CBSIZE      = CB.(2:14)#;     << control block size >>                  01784000
                                                                        01786000
<<----------------------------------------------------------------------01788000
*                                                                      *01790000
*  Control Block Lock (CBL) definitions                                *01792000
*                                                                      *01794000
---------------------------------------------------------------------->>01796000
                                                                        01798000
DEFINE                                                                  01800000
CBLCONTROL  = CBL#,           << control word >>                        01802000
CBLLOCK     = CBL.(0:1)#,     << lock bit >>                            01804000
CBLBREAK    = CBL.(1:1)#,     << break queue established >>             01806000
CBLCOUNT    = CBL.(2:6)#,     << lock count >>                          01808000
CBLPIN      = CBL.(8:8)#,     << process PIN holding lock >>            01810000
CBLQUEUE    = CBL(1)#,        << high priority impeded queue >>         01812000
CBLTAIL     = CBL(1).(0:8)#,  << tail process PIN >>                    01814000
CBLHEAD     = CBL(1).(8:8)#,  << head process PIN >>                    01816000
CBLSAVEDQUEUE= CBL(2)#,       << low priority impeded queue >>          01818000
CBLSAVEDTAIL= CBL(2).(0:8)#,  << tail process PIN >>                    01820000
CBLSAVEDHEAD= CBL(2).(8:8)#;  << head process PIN >>                    01822000
                                                                        01824000
<<----------------------------------------------------------------------01826000
*                                                                      *01828000
*  Available File Table (AFT) entry definitions                  KS.00 *01830000
*                                                                      *01832000
---------------------------------------------------------------------->>01834000
                                                                        01836000
EQUATE                                                                  01838000
AFTENTRY    = 4;    << AFT entry size >>                                01840000
                                                                        01842000
DEFINE                                                                  01844000
AFTTYPE     = AFT.(0:4)#,     << entry type >>                 <<DS.00>>01846000
AFTFSTYPE   = (AFTTYPE = 0)#, << FS entry type >>              <<DS.00>>01848000
AFTRFTYPE   = (AFTTYPE = 1)#, << RF entry type >>              <<DS.00>>01850000
AFTDSTYPE   = (AFTTYPE&LSR(1) = 1)#, << DS entry type >>       <<DS.00>>01852000
AFTCSTYPE   = (AFTTYPE&LSR(1) = 2)#, << CS entry type >>       <<DS.00>>01854000
AFTKSTYPE   = (AFTTYPE=6)#,          << KS entry type >>       <<KS.00>>01856000
AFT3270TYPE = (AFTTYPE = 7)#,                                  <<00183>>01858000
AFTMSGTYPE   = (AFTTYPE = 8)#,                                 <<HM.00>>01860000
AFTNULL     = LOG(AFT.(4:1))#,      << $NULL file >>           <<DS.00>>01862000
NULLFIELD   = (4:1)#,                                                   01864000
AFTDSKLUDGE = (AFTTYPE <> 2)#,<< no I/O Wait line - DS only >> <<DS.00>>01866000
AFTLDEV     = AFT.(8:8)#,     << logical device nr. - CS only >>        01868000
AFTFLAG     = AFT.(5:2)#,            << KS error flag>>        <<KS.00>>01870000
AFTERRNUM   = AFT.(8:8)#,            <<KSAM special error #>>  <<KS.00>>01872000
AFTPACBV    = AFT(1)#,        << physical ACB vector >>                 01874000
AFTCSIOQCBV = AFT(1)#,        << CS IOQ index CB vector >>     <<00613>>01876000
AFTRFNUM    = AFT(1).(0:8)#,  << remote file number >>         <<DS.00>>01878000
AFTLINENUM  = AFT(1).(8:8)#,  << local line # of remote file >><<DS.00>>01880000
AFTKEYFN    = AFT(1).(0:8)#,         <<KSAM key file number>>  <<KS.00>>01882000
AFTDATAFN   = AFT(1).(8:8)#,         <<KSAM data file number>> <<KS.00>>01884000
AFTLACBV    = AFT(2)#,        << logical ACB vector >>                  01886000
                                     <<0 = no error>>          <<KS.00>>01888000
                                     <<1 = data file error>>   <<KS.00>>01890000
                                     <<2 = key file error>>    <<KS.00>>01892000
                                     <<3 = KSAM special err>>  <<KS.00>>01894000
AFTEDSNUM   = AFT(2)#,               <<KSAM extra data seg #>> <<KS.00>>01896000
AFTCS'MDST  = AFT(2).(6:10)#, << CS info data segment for AFT>><<00613>>01898000
AFTIOQX     = AFT(3)#;        << No-Wait I/O IOQX >>                    01900000
                                                                        01902000
DEFINE                                                                  01904000
FINDAFT     = PUSH(DL); TOS := TOS-4-FILENUM*AFTENTRY#,                 01906000
FINDAFT'    = TOS:=-TOS*AFTENTRY-4; PUSH(DL); TOS:=TOS+TOS#,   <<01817>>01908000
SETAFT      = FINDAFT; @AFT := TOS#,                           <<01817>>01910000
SETAFT'     = FINDAFT'; @AFT := TOS#;                          <<01817>>01912000
DEFINE VTA =&LSR(10)&LSL(2)+FSOVERHEAD#;                                01914000
DEFINE DSTN=(6:10)#;                                                    01916000
                                                                        01918000
<<-------------------------------------------------------------  DS.00  01920000
*                                                             *  DS.00  01922000
*  AFT file entry types                                       *  KS.00  01924000
*                                                             *  DS.00  01926000
---------------------------------------------------------------  DS.00>>01928000
                                                               <<DS.00>>01930000
DEFINE                                                         <<DS.00>>01932000
FSTYPE      = (FTYPE = 0)#,         << local file >>           <<DS.00>>01934000
RFTYPE      = (FTYPE = 1)#,         << remote file >>          <<DS.00>>01936000
DSTYPE      = (FTYPE&LSR(1) = 1)#,  << DS file type >>         <<DS.00>>01938000
CSTYPE      = (FTYPE&LSR(1) = 2)#;  << CS file type >>         <<DS.00>>01940000
DEFINE                                                         <<KS.00>>01942000
KSTYPE      = (FTYPE = 6)#;         << KSAM file type >>       <<KS.00>>01944000
DEFINE                                                         <<00183>>01946000
  TTSTYPE     = ( FTYPE = 7)#;                                 <<00183>>01948000
DEFINE                                                         <<HM.00>>01950000
MSGTYPE     = (FTYPE = 8)#;         << MSG FILE TYPE >>        <<HM.00>>01952000
EQUATE FS'TYPE = 0;                                            <<+1.C3>>01954000
EQUATE RF'TYPE = 1;                                            <<+1.C3>>01956000
EQUATE KS'TYPE = 6;                                            <<+1.C3>>01958000
EQUATE MSG'TYPE= 8;                                            <<HM.00>>01960000
   EQUATE LEGAL'FTYPES = %141200;                                       01962000
                                                               <<DS.00>>01964000
<<----------------------------------------------------------------------01966000
*                                                                      *01968000
*  Logical Access Control Block (LACB) definitions                     *01970000
*                                                                      *01972000
---------------------------------------------------------------------->>01974000
                                                                        01976000
EQUATE                                                                  01978000
SIZELACB    = 16;     << LACB size in words >>                          01980000
EQUATE SIZENOWR = 10,    << read-only part of LACB >>                   01982000
       SIZELACBWR = SIZELACB-SIZENOWR;                                  01984000
                                                                        01986000
                                                                        01988000
<<----------------------------------------------------------------------01990000
*                                                                      *01992000
*  Access Control Block (ACB) definitions                              *01994000
*                                                                      *01996000
---------------------------------------------------------------------->>01998000
                                                                        02000000
EQUATE                                                                  02002000
SIZEACB     =48,     << Basic ACB size >>                               02004000
       SIZEPACBWR = SIZEACB-SIZENOWR,                                   02006000
       SIZEMRPACB = SIZEACB-SIZELACB,                                   02008000
BLKBUFDISP  =08;     << Buffering extension size >>            <<04875>>02010000
                                                                        02012000
DEFINE                                                                  02014000
ACBSIZE     =ACB.(2:14)#,     << size of ACB (incl. buffs) >>           02016000
ACBFNUM     =ACB(1).(8:8)#,   << file number >>                         02018000
ACBNAME     =ACB(2)#,         << file name >>                           02020000
ACBNAME1    =ACBDBL(1)#,      << file name - first half >>              02022000
ACBNAME2    =ACBDBL(2)#,      << file name - second half >>             02024000
ACBFOPTIONS =ACB(6)#,         << FOPTIONS >>                            02026000
ACBAOPTIONS =ACB(7)#,         << AOPTIONS >>                            02028000
ACBRSIZE    =ACB(8)#,         << record size (bytes) >>                 02030000
ACBBSIZE    =ACB(9)#,         << block size (words) >>                  02032000
                                                                        02034000
ACBCTL      =ACB(11)#,        << carriage control word >>               02036000
ACBLSTATE   =ACB(12)#,        << local state flags >>                   02038000
ACBMODW     =ACB(13)#,        << mode word >>                           02040000
ACBMODE     =ACBMODW.(0:8)#,  << mode setting >>                        02042000
ACBTAPEERROR=LOG(ACBMODW.(4:1))#,<< report recovered tape error >>      02044000
ACBINHIBCRLF=LOG(ACBMODW.(5:1))#,<< inhibit terminal CR/LF >>           02046000
ACBQUIESCE  =LOG(ACBMODW.(6:1))#,<< critical output verify >>           02048000
ACBCIROVERFL=LOG(ACBMODW.(7:1))#,<< wrap on write to cir file>><<HM.00>>02050000
ACBSTOPCHAR =ACBMODW.(8:8)#,  << terminal stop character >>             02052000
ACBERROR    =ACB(14)#,        << error code >>                          02054000
ACBTLOG     =ACB(15)#,        << last I/O transmission log >>           02056000
ACBFPTR     =ACBDBL(08)#,     << current record number >>               02058000
ACBBLK      =ACBDBL(09)#,     << current variable block >>              02060000
ACBRTFRCT   =ACBDBL(10)#,     << logical record tfr count >>            02062000
ACBBTFRCT   =ACBDBL(11)#,     << block transfer count >>                02064000
ACBHIBLK    =ACBDBL(12)#,     << highest block started >>               02066000
ACBFCB      =ACB(26)#,        << FCB vector >>                          02068000
                                                                        02070000
ACBSHCNTS   =ACB(28)#,        << LACB counts >>                         02072000
ACBSHCNTIN  =ACBSHCNTS.(0:8)#,<< # of Read LACB'S >>                    02074000
ACBSHCNT    =ACBSHCNTS.(8:8)#,<< # of LACB'S >>                         02076000
ACBSTATW    =ACB(29)#,        << access class, status, etc. >>          02078000
ACBBREAK    =ACBSTATW.(1:1)#, << break ($STDIN/LIST only) >>            02080000
ACBDTYPE    =ACBSTATW.(2:6)#, << device type >>                         02082000
ACBACCCL    =ACBSTATW.(2:3)#, << device access class >>                 02084000
ACBSUBCL    =ACBSTATW.(5:3)#, << device sub-class >>                    02086000
ACBSTATUS   =ACBSTATW.(8:8)#, << last logical I/O status >>             02088000
ACBQSTATUS  =ACBSTATW.(8:5)#, << qualifying status part >>              02090000
ACBGSTATUS  =ACBSTATW.(13:3)#,<< general status part >>                 02092000
ACBGSTW     =ACB(30)#,        << global state flags >>                  02094000
ACBNOWAITEOF=ACBGSTW.(0:1)#,  << EOF advanced? >>                       02096000
ACBNOWAITMODE=ACBGSTW.(1:1)#, << last I/O: 0=read, 1=write >>           02098000
ACBABORTREAD=ACBGSTW.(2:1)#,  << abort broken re-read? >>               02100000
ACBNEWEOF   =ACBGSTW.(3:1)#,  << EOF advanced - tape file >>            02102000
ACBSAVEEOFS =ACBGSTW.(4:2)#,  << for saving ACBEOFS >>                  02104000
ACBEOFS     =ACBGSTW.(6:2)#,  << EOF flags - :EOD/: >>                  02106000
ACBBLKFACT  =ACBGSTW.(8:8)#,  << records/block >>                       02108000
ACBBUFX     =ACB(31)#,        << buffer data & misc. flags >>           02110000
ACBPRIV     =ACBBUFX.(0:1)#,  << privileged access only >>              02112000
ACBHIT      =ACBBUFX.(1:1)#,  << buffer hit flag >>                     02114000
ACBCURRBUF  =ACBBUFX.(4:4)#,  << current buffer nr. >>                  02116000
ACBNUMBUFS  =ACBBUFX.(12:4)#, << number of buffers less 1>>             02118000
ACBBUFUSED  =ACB(32)#,        << used block word count >>               02120000
ACBBUFSIZE  =ACB(33)#,        << buffer size (words) >>                 02122000
ACBXXXX     =ACB(34)#,        << spare >>                               02124000
ACBFMAVTX   =ACB(35)#,        << FMAVT index >>                         02126000
ACBVDADDR   =ACB(36)#,        << volume table index >>                  02128000
ACBDNTD     =ACB(37)#,        << type & disposition >>                  02130000
ACBDNTYPE   =ACBDNTD.(0:8)#,  << name type for dir. search >>           02132000
ACBDISP     =ACBDNTD.(8:8)#,  << file disposition >>                    02134000
ACBAMLD     =ACB(38)#,        << access mask & LDEV >>                  02136000
ACBACCESS   =ACBAMLD.(0:8)#,  << access mask >>                         02138000
ACBDADDR    =ACBAMLD.(8:8)#,  << logical device number >>               02140000
                                                                        02142000
ACBSPFL     =ACB(39)#,        << spool control flags >>                 02144000
ACBSPOOLED  =LOG(ACBSPFL.(0:1))#,<< spooled device flag >>              02146000
ACBSPOOLIO  =ACBSPFL.(0:2)#,  << spooled IN/OUT >>                      02148000
ACBSPSQZ    =ACBSPFL.(2:1)#,  << file squeezed >>                       02150000
ACBSPRSQ    =ACBSPFL.(3:1)#,  << request to sqz >>                      02152000
ACBSPVDEV   =ACBSPFL.(8:8)#,  << spooled virtual device >>              02154000
ACBSPTYRC   =ACB(40)#,        << spooled dev type/recsize>>             02156000
ACBSPTYPE   =ACBSPTYRC.(0:6)#,<< spooled dev type >>                    02158000
ACBSPREC    =ACBSPTYRC.(6:10)#,<< spooled dev rec size >>               02160000
ACBSPFOPT   =LOG(ACB(41))#,   << spooled dev FOPTIONS >>                02162000
ACBSPAOPT   =LOG(ACB(42))#,   << spooled dev AOPTIONS >>                02164000
ACBSPXDDX   =ACB(43)#,        << IDD/ODD index >>                       02166000
ACBNOWAITDA =ACBDBL(22)#,     << No-wait disk address >>                02168000
ACBNOWAITLDEV=ACB(27)#,                                                 02170000
                                                                        02172000
<< 46-47 are used for FDEVICECONTROL only. >>                           02174000
                                                                        02176000
                                                                        02178000
ACBBUFPOOL  =ACB(SIZEACB)#,   << buffer pool origin >>                  02180000
                                                                        02182000
BLKIOQX     =BLK#,            << IOQ entry nr. >>                       02184000
BLKFLAGS    =BLK(1).(13:3)#,  << I/O flags >>                           02186000
BLKIOOUT    =BLK(1).(13:1)#,  << last I/O was write? >>                 02188000
BLKDIRTY    =BLK(1).(14:1)#,  << buffer modified? >>                    02190000
BLKIOPEND   =LOG(BLK(1).(15:1))#,  << I/O in progress? >>               02192000
BLKIOCOMP   =BLK(1).(14:2)#,  << I/O complete - not dirty >>            02194000
BLKIOCB     =BLKDBL(1)#,      << IOCB >>                                02196000
BLKLSTAT    =BLK(2)#,         << IOCB - STATUS >>                       02198000
BLKTLOG     =BLK(3)#,         << IOCB - transmission log >>             02200000
BLKBLOCK    =BLKDBL(2)#,      << block number >>                        02202000
BLKDADDR    =BLKDBL(3)#,      << block sector number >>                 02204000
BLKLDEV     =BLK(6).(0:8)#,   << block logical device nr. >>            02206000
BLKBUFFER   =BLK(BLKBUFDISP)#;<< buffer >>                              02208000
                                                                        02210000
                                                                        02212000
DEFINE  << ACBLSTATE definitions >>                                     02214000
ACBEOF      =ACBLSTATE.(1:1)#, << End Of File sensed >>                 02216000
ACBLPCTL    =ACBLSTATE.(2:2)#, << Page and Line control >>              02218000
ACBPAGECTL  =ACBLSTATE.(2:1)#, << Page control: 0=60 LPP 1=66 LPP >>    02220000
ACBLINECTL  =ACBLSTATE.(3:1)#, << Line control: 0=post 1=prespace >>    02222000
ACBSTREAM   =ACBLSTATE.(4:1)#, << Stream I/O >>                         02224000
ACBFKEYS    =ACBLSTATE.(5:1)#, << restore function keys >>              02226000
ACBXMITCRLF =ACBLSTATE.(6:1)#, << transmit CR,LF to user buffer >>      02228000
ACBTBLOCK   =ACBLSTATE.(7:1)#, << disable terminal block mode >>        02230000
ACBBINARYIO =ACBLSTATE.(8:1)#, << eight bit terminal transfers >>       02232000
ACBCARRIAGE =ACBLSTATE.(9:1)#, << carriage control flag >>              02234000
ACBDEFBLOCK =ACBLSTATE.(10:1)#,<< default blocking >>                   02236000
ACBREADCODE =ACBLSTATE.(11:4)#,<< input EOF check >>                    02238000
ACBREADTYPE =ACBLSTATE.(11:2)#,<< input EOF type >>                     02240000
ACBREADMODE =ACBLSTATE.(13:2)#;<< input EOF mode >>                     02242000
                                                                        02244000
DEFINE  <<AOPTIONS DEFINITIONS>>                                        02246000
ACBCOPY         = LOG(ACBAOPTIONS.(3:1))#,<< COPY/REPLICATE >> <<HM.00>>02248000
ACBNOWAIT       = LOG(ACBAOPTIONS.(4:1))#,<< No-Wait I/O mode >>        02250000
ACBMULTAC       = ACBAOPTIONS.(5:2)#,     << multi-access mode >>       02252000
ACBGLOBALMULTAC = ACBAOPTIONS.(6:1)#,     << GLOBAL MULTI >>   <<HM.00>>02254000
ACBINHIBITBUF   = LOG(ACBAOPTIONS.(7:1))#,<< inhibit buffering >>       02256000
ACBACMODE       = ACBAOPTIONS.(8:2)#,     << access mode >>             02258000
ACBDEFAULT      = (ACBACMODE = 0)#,       << default >>                 02260000
ACBEXCLUSIVE    = (ACBACMODE = 1)#,       << exclusive >>               02262000
ACBSEMI         = (ACBACMODE = 2)#,       << semi-exclusive >>          02264000
ACBSHARE        = (ACBACMODE = 3)#,       << share >>                   02266000
ACBLOCKING      = LOG(ACBAOPTIONS.(10:1))#,<< dynamic locking >>        02268000
ACBMULTIREC     = LOG(ACBAOPTIONS.(11:1))#,<< multi-record >>           02270000
ACBACTYPE       = ACBAOPTIONS.(12:4)#,    << access type >>             02272000
ACBREAD         = (ACBACTYPE = 0)#,       << read only >>               02274000
ACBWRITE        = (ACBACTYPE = 1)#,       << write only - delete >>     02276000
ACBWRITESAVE    = (ACBACTYPE = 2)#,       << write only - save >>       02278000
ACBAPPEND       = (ACBACTYPE = 3)#,       << append only >>             02280000
ACBREADWRITE    = (ACBACTYPE = 4)#,       << read/write >>              02282000
ACBUPDATE       = (ACBACTYPE = 5)#,       << update only >>             02284000
ACBEXECUTE      = (ACBACTYPE = 6)#;       << execute only >>            02286000
                                                                        02288000
DEFINE  <<FOPTIONS definitions>>                                        02290000
ACBFILETYPE     = ACBFOPTIONS.(2:3)#,     << FILE TYPE >>      <<HM.00>>02292000
ACBFKSAM        = (ACBFFILETYPE=1)#,      << RESERVED FOR KSAM   HM.00>>02294000
ACBRIO          = (ACBFILETYPE=2)#,       << RIO FILE >>       <<HM.00>>02296000
ACBCIRFILE      = (ACBFILETYPE=4)#,       << CIRCULAR FILE >>  <<HM.00>>02298000
ACBMSGFILE      = (ACBFILETYPE=6)#,       << IPC FILE >>       <<HM.00>>02300000
ACBNOEQUATE     = LOG(ACBFOPTIONS.(5:1))#,<< no file equation >>        02302000
ACBLABELLED     = LOG(ACBFOPTIONS.(6:1))#,                     <<TL.02>>02304000
ACBCONTROL      = LOG(ACBFOPTIONS.(7:1))#,<< carriage control >>        02306000
ACBFORMAT       = ACBFOPTIONS.(8:2)#,     << record format >>           02308000
ACBVARFLD       = ACBFOPTIONS.(9:1)#,     << variable bit >>            02310000
ACBFIXED        = (ACBFORMAT = 0)#,       << fixed >>                   02312000
ACBVARIABLE     = (ACBVARFLD = 1)#,       << variable >>                02314000
ACBNORMVAR      = (ACBFORMAT = 1)#,       << normal var >>              02316000
ACBSPECVAR      = (ACBFORMAT = 3)#,       << special var >>             02318000
ACBUNDEFINED    = (ACBFORMAT = 2)#,       << undefined >>               02320000
ACBDESIGNATOR   = ACBFOPTIONS.(10:3)#,    << designator type >>         02322000
ACBACTUAL       = (ACBDESIGNATOR = 0)#,   << actual >>                  02324000
ACBSTDLIST      = (ACBDESIGNATOR = 1)#,   << $STDLIST >>                02326000
ACBNEWPASS      = (ACBDESIGNATOR = 2)#,   << $NEWPASS >>                02328000
ACBOLDPASS      = (ACBDESIGNATOR = 3)#,   << $OLDPASS >>                02330000
ACBSTDIN        = (ACBDESIGNATOR = 4)#,   << $STDIN >>                  02332000
ACBSTDINX       = (ACBDESIGNATOR = 5)#,   << $STDINX >>                 02334000
ACBNULL         = (ACBDESIGNATOR = 6)#,   << $NULL >>                   02336000
ACBASCII        = LOG(ACBFOPTIONS.(13:1))#,<< ASCII format >>           02338000
ACBDOMAIN       = ACBFOPTIONS.(14:2)#,    << file domain >>             02340000
ACBNEW          = (ACBDOMAIN = 0)#,       << new >>                     02342000
ACBPERMANENT    = (ACBDOMAIN = 1)#,       << old - permanent >>         02344000
ACBTEMPORARY    = (ACBDOMAIN = 2)#,       << old - temporary >>         02346000
ACBOLD          = (ACBDOMAIN = 3)#;       << old - either >>            02348000
DEFINE    << ACB' definitions >>                                        02350000
   ACB'TAPEERROR =ACB'MODW.(4:1)#,                                      02352000
   ACB'INHIBCRLF =ACB'MODW.(5:1)#,                                      02354000
   ACB'QUIESCE   =ACB'MODW.(6:1)#,                                      02356000
   ACB'STOPCHAR  =ACB'MODW.(8:8)#,                                      02358000
                                                                        02360000
   ACB'BREAK     =ACB'STATW.(1:1)#,                                     02362000
   ACB'ACCCL     =ACB'STATW.(2:3)#,                                     02364000
   ACB'DTYPE     =ACB'STATW.(2:6)#,                                     02366000
   ACB'STATUS    =ACB'STATW.(8:8)#,                                     02368000
   ACB'GSTATUS   =ACB'STATW.(13:3)#,                                    02370000
                                                                        02372000
   ACB'NOWAITEOF =ACB'GSTW.(0:1)#,                                      02374000
   ACB'NOWAITMODE=ACB'GSTW.(1:1)#,                                      02376000
   ACB'ABORTREAD =ACB'GSTW.(2:1)#,                                      02378000
   ACB'NEWEOF    =ACB'GSTW.(3:1)#,                                      02380000
   ACB'EOFS      =ACB'GSTW.(6:2)#,                                      02382000
   ACB'BLKFACT   =INTEGER(ACB'GSTW.(8:8))#,                             02384000
                                                                        02386000
   ACB'EOF       =ACB'LSTATE.(1:1)#,                                    02388000
   ACB'LPCTL     =ACB'LSTATE.(2:2)#,                                    02390000
   ACB'PAGECTL   =ACB'LSTATE.(2:1)#,                                    02392000
   ACB'LINECTL   =ACB'LSTATE.(3:1)#,                                    02394000
   ACB'STREAM    =ACB'LSTATE.(4:1)#,                                    02396000
   ACB'XMITCRLF  =ACB'LSTATE.(6:1)#,                                    02398000
   ACB'TBLOCK    =ACB'LSTATE.(7:1)#,                                    02400000
   ACB'BINARYIO  =ACB'LSTATE.(8:1)#,                                    02402000
   ACB'CARRIAGE  =ACB'LSTATE.(9:1)#,                                    02404000
   ACB'READCODE  =ACB'LSTATE.(11:4)#,                                   02406000
                                                                        02408000
   ACB'SPOOLED   =ACB'SPFL.(0:1)#,                                      02410000
   ACB'SPSQZ     =ACB'SPFL.(2:1)#,                                      02412000
   ACB'SPRSQ     =ACB'SPFL.(3:1)#,                                      02414000
                                                                        02416000
   ACB'RIO       =(ACB'FOPTIONS.(2:3)=2)#,                     <<HM.00>>02418000
   ACB'CIRFILE   =(ACB'FOPTIONS.(2:3)=4)#,                     <<HM.00>>02420000
   ACB'MSGFILE   =(ACB'FOPTIONS.(2:3)=6)#,                     <<HM.00>>02422000
   ACB'LABELLED  =ACB'FOPTIONS.(6:1)#,                                  02424000
   ACB'CONTROL   =ACB'FOPTIONS.(7:1)#,                                  02426000
   ACB'FIXED     =ACB'FOPTIONS.(8:2)=0#,                                02428000
   ACB'VARIABLE  =ACB'FOPTIONS.(9:1)#,                                  02430000
   ACB'NORMVAR   =ACB'FOPTIONS.(8:2)=1#,                                02432000
   ACB'SPECVAR   =ACB'FOPTIONS.(8:2)=3#,                                02434000
   ACB'UNDEFINED =ACB'FOPTIONS.(8:2)=2#,                                02436000
   ACB'ASCII     =ACB'FOPTIONS.(13:1)#,                                 02438000
                                                                        02440000
   ACB'SPREC     =ACB'SPTYRC.(6:10)#,                                   02442000
   ACB'PRIV      =ACB'BUFX.(0:1)#,                                      02444000
   ACB'CURRBUF   =ACB'BUFX.(4:4)#,                                      02446000
   ACB'TAPEDISP  =ACB'BUFX.(8:4)#,                             <<04591>>02448000
   ACB'NUMBUFS   =ACB'BUFX.(12:4)#,                                     02450000
   ACB'ACCESS    =ACB'AMLD.(0:8)#,                                      02452000
   ACB'DADDR     =ACB'AMLD.(8:8)#,                                      02454000
                                                                        02456000
   ACB'NOWAIT    =ACB'AOPTIONS.(4:1)#,                                  02458000
   ACB'INHIBITBUF=ACB'AOPTIONS.(7:1)#,                                  02460000
   ACB'MULTIREC  =ACB'AOPTIONS.(11:1)#,                                 02462000
   ACB'APPEND    =(ACB'ACTYPE=3)#,                             <<02353>>02464000
   ACB'ACTYPE    =INTEGER(ACB'AOPTIONS.(12:4))#,                        02466000
                                                                        02468000
   LABEL'DEVICE    = ACB'LABELLED AND ACB'ACCCL = SERIALIO#;   <<03582>>02470000
                                                                        02472000
<< Define the most commonly used ACB elements: >>                       02474000
                                                                        02476000
DEFINE BUILD'ACB =                                                      02478000
   LOGICAL ACB'FOPTIONS = ACB+6;                                        02480000
   LOGICAL ACB'AOPTIONS = ACB+7;                                        02482000
   LOGICAL ACB'LSTATE   = ACB+12;                                       02484000
   INTEGER ACB'ERROR    = ACB+14;                                       02486000
   DOUBLE ACB'FPTR      = ACB+16;                                       02488000
   INTEGER ACB'FCB      = ACB+26;                                       02490000
   LOGICAL ACB'STATW    = ACB+29;                                       02492000
   LOGICAL ACB'GSTW     = ACB+30;                                       02494000
   INTEGER ACB'BUFX     = ACB+31;                                       02496000
   INTEGER ACB'AMLD     = ACB+38;                                       02498000
   LOGICAL ACB'SPFL     = ACB+39#;                                      02500000
                                                                        02502000
                                                               <<04559>>02504000
<<**********************************************************>> <<04559>>02506000
<< Used to calculate Q relative location of ACB and FCB     >> <<04559>>02508000
<< ACBMQ is used in calls to LOC'ACB and UNLOC'ACB and FCBMQ>> <<04559>>02510000
<< is used in calls to LOCK'CB.  We must P-Disable our-     >> <<04559>>02512000
<< selves since  the LRA instruction does not work in split >> <<04559>>02514000
<< stack mode if DB moves between instructions.             >> <<04559>>02516000
<<**********************************************************>> <<04559>>02518000
                                                               <<04559>>02520000
DEFINE GET'ACB'Q'LOC =                                         <<04559>>02522000
          PSEUDODISABLE;                                       <<04559>>02524000
          ACBMQ := @ACB - @Q0;                                 <<04559>>02526000
          PSEUDOENABLE#;                                       <<04559>>02528000
                                                               <<04559>>02530000
DEFINE GET'FCB'Q'LOC =                                         <<04559>>02532000
          PSEUDODISABLE;                                       <<04559>>02534000
          FCBMQ := @FCB - @Q0;                                 <<04559>>02536000
          PSEUDOENABLE#;                                       <<04559>>02538000
                                                               <<04559>>02540000
DEFINE GET'FCB'PRIME'Q'LOC =   << Using FCB' instead of FCB >> <<04559>>02542000
          PSEUDODISABLE;                                       <<04559>>02544000
          FCBMQ := @FCB' - @Q0;                                <<04559>>02546000
          PSEUDOENABLE#;                                       <<04559>>02548000
                                                               <<04559>>02550000
DEFINE  <<MISC. DEFINITIONS>>                                           02552000
ACBSTATUSCODE   = [2/CCL,2/CCL,2/CCG,2/CCE,2/CCL]                       02554000
                  &LSR(ACBGSTATUS*2)#;                                  02556000
                                                                        02558000
<< ACB Extension [ACBX] definitions >>                                  02560000
                                                                        02562000
INTEGER ARRAY XPACBD(*) = Q+48;                                         02564000
   DEFINE XPACBDST  = XPACBD(X)#;                                       02566000
INTEGER ARRAY XPACBO(*) = Q+49;                                         02568000
   DEFINE XPACBOFST = XPACBO(X)#;                                       02570000
INTEGER ARRAY XLACBD(*) = Q+50;                                         02572000
   DEFINE XLACBDST  = XLACBD(X)#;                                       02574000
INTEGER ARRAY XLACBO(*) = Q+51;                                         02576000
   DEFINE XLACBOFST = XLACBO(X)#;                                       02578000
INTEGER ARRAY XACBO(*)  = Q+52;                                         02580000
   DEFINE XACBOFST  = XACBO(X)#;                                        02582000
INTEGER ARRAY XDBO(*)   = Q+53;                                         02584000
   DEFINE XDBOFST   = XDBO(X)#;                                         02586000
INTEGER ARRAY XPXCBO(*) = Q+54;                                         02588000
   DEFINE XPXCBTOFST = XPXCBO(X)#;                                      02590000
INTEGER ARRAY XPACVO(*) = Q+55;                                         02592000
   DEFINE XPACBVTA = XPACVO(X)#;                                        02594000
                                                                        02596000
EQUATE SIZEXACB = 56;                                                   02598000
                                                                        02600000
<<----------------------------------------------------------------------02602000
*                                                                      *02604000
*  File Control Block (FCB) definitions                                *02606000
*                                                                      *02608000
---------------------------------------------------------------------->>02610000
                                                                        02612000
EQUATE                                                                  02614000
SIZEBFCB    = 36,   << SIZE OF FCB LESS EXTENT MAP >>          <<HM.00>>02616000
SIZEDFCB    = 2*MAXEXTENTS+SIZEBFCB;   << maximum disc FCB >>           02618000
                                                                        02620000
DEFINE                                                                  02622000
FCBSIZE     =FCB.(2:14)#,     << size of FCB >>                         02624000
FCBNEWFCBV  =FCB(1)#,         << new FCB vector >>                      02626000
FCBFOPTIONS =FCB(2)#,         << FOPTIONS >>                            02628000
FCBDEVICE   =FCB(3)#,         << pos. LDEV or neg. device class index >>02630000
FCBLKST     =FCB(4).(0:2)#,   << previous lock state >>                 02632000
FCBDTYPE    =FCB(4).(2:6)#,   << device type - first extent >>          02634000
FCBSUBTYPE  =FCB(4).(12:4)#,  << device sub-type - first extent >>      02636000
FCBOCNTOUT  =FCB(5).(0:8)#,   << # processes accessing - output mode >> 02638000
FCBOCNT     =FCB(5).(8:8)#,   << # processes accessing - any mode >>    02640000
FCBACB      =FCB(6)#,         << creator ACB vector >>                  02642000
FCBRIN      =FCB(7)#,         << RIN # >>                               02644000
FCBEXCLSTAT =FCB(8)#,         << exclusive status >>                    02646000
FCBPVINFO   =FCB (9) #,       <<CLASSFLG,VMASK & MVTABX if PV>><<RV.PV>>02648000
FCBCLASSFLG =FCBPVINFO.(0:1)#,<< CLASSFLG >>                   <<RV.PV>>02650000
FCBMVTABX   =FCBPVINFO.(4:4)#,<< MVTABX >>                     <<RV.PV>>02652000
FCBVMASK    =FCVPVINFO.(8:8)#,<< VMASK >>                      <<RV.PV>>02654000
FCBFLIM     =FCBDBL(5)#,      << maximum # blocks >>                    02656000
FCBIMAGE    =FCBDBL(6)#,      << reserved for IMAGE >>                  02658000
FCBEOF      =FCBDBL(7)#,      << end of data pointer >>                 02660000
FCBUSERLBL  =FCB(16)#,        << user labels >>                         02662000
FCBLBLEOF   =FCB(16).(0:8)#,  << # labels written >>                    02664000
FCBLBL      =FCB(16).(8:8)#,  << # of user labels >>                    02666000
FCBEXTSIZE  =FCB(17)#,        << extent size >>                         02668000
FCBBLKFACT  =FCB(18).(0:8)#,  << blocking factor >>                     02670000
FCBSECTPBLK =FCB(18).(8:8)#,  << sectors per block >>                   02672000
FCBSECTOFF  =FCB(19).(0:8)#,  << sector offset to data >>               02674000
FCBDISP     =FCB (19).(8:3)#, << pending file disposition >>   <<RV.PV>>02676000
FCBNUMEXTS  =FCB(19).(11:5)#, << number of extents - 1>>                02678000
FCBLASTEXTSIZE=FCB(20)#,      << last extent size >>                    02680000
FCBOCNTIN   =FCB(21).(8:8)#,  << # processes accessing - input mode >>  02682000
FCBGN       =FCB(22)#,        << group name >>                          02684000
FCBGN1      =FCBDBL(11)#,     << group name - first half >>             02686000
FCBGN2      =FCBDBL(12)#,     << group name - second half >>            02688000
FCBAN       =FCB(26)#,        << account name >>                        02690000
FCBAN1      =FCBDBL(13)#,     << account name - first half >>           02692000
FCBAN2      =FCBDBL(14)#,     << account name - second half >>          02694000
FCBSTART    =FCBDBL(15)#,     << ABSOLUTE START BLOCK >>       <<HM.00>>02696000
FCBEND      =FCBDBL(16)#,     << VARIABLE LENGTH RECORDS - >>  <<HM.00>>02698000
                              << END BLOCK #, REL TO START BLK   HM.00>>02700000
FCBHDRECS   =FCBDBL(17)#,     << NUMBER OF NONDATA HEADER REC ><<HM.00>>02702000
FCBLABEL    =FCBDBL(18)#,     << FILE LABEL LDEV AND SECTOR NUM<<HM.00>>02704000
FCBLDEV     =FCB(36).(0:8)#,  << FILE LABEL LDEV >>            <<HM.00>>02706000
FCBEXTMAP   =FCB(36)#;        << EXTENT MAP >>                 <<HM.00>>02708000
                                                                        02710000
EQUATE XFLIM = 10,          << word indices of FCB items >>             02712000
       XEOF  = 14,                                             <<HM.00>>02714000
       XEND  = 32,                                             <<HM.00>>02716000
       EOF'END'DISP = XEND-XEOF-2;                             <<HM.00>>02718000
                                                                        02720000
DEFINE  <<FOPTIONS definitions>>                                        02722000
FCBFILETYPE   = FCBFOPTIONS.(2:3)#,     << FILE TYPE >>        <<HM.00>>02724000
FCBKSAM       = (FCBFILETYPE=1)#,       << RESERVED FOR KSAM >><<HM.00>>02726000
FCBRIO        = (FCBFILETYPE=2)#,       <<RIO FILE>>           <<HM.00>>02728000
FCBCIRFILE    = (FCBFILETYPE=4)#,       << CIRCULAR FILE >>    <<HM.00>>02730000
FCBMSGFILE    = (FCBFILETYPE=6)#,       << IPC FILE >>         <<HM.00>>02732000
FCBNOEQUATE   = LOG(FCBFOPTIONS.(5:1))#,<< no file equation >>          02734000
FCBUNLABELLED = LOG(FCBFOPTIONS.(6:1))#,<< unlabelled tape >>           02736000
FCBCONTROL    = LOG(FCBFOPTIONS.(7:1))#,<< carriage control >>          02738000
FCBFORMAT     = FCBFOPTIONS.(8:2)#,     << record format >>             02740000
FCBVARFLD     = FCBFOPTIONS.(9:1)#,     << variable bit >>              02742000
FCBFIXED      = (FCBFORMAT = 0)#,       << fixed >>                     02744000
FCBVARIABLE   = (FCBVARFLD = 1)#,       << variable >>                  02746000
FCBNORMVAR    = (FCBFORMAT = 1)#,       << normal var >>                02748000
FCBSPECVAR    = (FCBFORMAT = 3)#,       << special var >>               02750000
FCBUNDEFINED  = (FCBFORMAT = 2)#,       << undefined >>                 02752000
FCBDESIGNATOR = FCBFOPTIONS.(10:3)#,    << designator type >>           02754000
FCBACTUAL     = (FCBDESIGNATOR = 0)#,   << actual >>                    02756000
FCBSTDLIST    = (FCBDESIGNATOR = 1)#,   << $STDLIST >>                  02758000
FCBNEWPASS    = (FCBDESIGNATOR = 2)#,   << $NEWPASS >>                  02760000
FCBOLDPASS    = (FCBDESIGNATOR = 3)#,   << $OLDPASS >>                  02762000
FCBSTDIN      = (FCBDESIGNATOR = 4)#,   << $STDIN >>                    02764000
FCBSTDINX     = (FCBDESIGNATOR = 5)#,   << $STDINX >>                   02766000
FCBNULL       = (FCBDESIGNATOR = 6)#,   << $NULL >>                     02768000
FCBASCII      = LOG(FCBFOPTIONS.(13:1))#,<< ASCII/BINARY FORMAT >>      02770000
FCBDOMAIN     = FCBFOPTIONS.(14:2)#,    << FILE DOMAIN >>               02772000
FCBNEW        = (FCBDOMAIN = 0)#,       << NEW >>                       02774000
FCBPERMANENT  = (FCBDOMAIN = 1)#,       << OLD - PERMANENT >>           02776000
FCBTEMPORARY  = (FCBDOMAIN = 2)#,       << OLD - TEMPORARY >>           02778000
FCBOLD        = (FCBDOMAIN = 3)#;       << OLD - EITHER >>              02780000
                                                                        02782000
<<----------------------------------------------------------------------02784000
*                                                                      *02786000
*  File Label definitions                                              *02788000
*                                                                      *02790000
---------------------------------------------------------------------->>02792000
                                                                        02794000
EQUATE                                                                  02796000
FLSKIP1     =  28,  << Lock bits index >>                               02798000
FLSKIP2     =  34,  << checksum index >>                                02800000
FLSKIP3     =  35,  << Cold Load ID index >>                            02802000
HARDFLABERR =   7,  << irrecoverable label error >>                     02804000
FLABERRNO   = 247;  << message catalog entry number >>                  02806000
                                                                        02808000
DEFINE                                                                  02810000
ALLOCFLAB   = PUSH(S); @FLAB := TOS+1; ASSEMBLE(ADDS 128)#,             02812000
BADFCBSIZE = NOT (%46 <= X <= %144)#,                          <<HM.00>>02814000
CHECKSUM    = TOS := -1;                                                02816000
              X := 127;                                                 02818000
              DO BEGIN                                                  02820000
                 IF X <> FLSKIP1 AND X <> FLSKIP2 AND X <> FLSKIP3 THEN 02822000
                    TOS := TOS XOR LOGICAL(FLAB(X));                    02824000
                 X := X-1                                               02826000
                 END UNTIL <#;                                          02828000
                                                                        02830000
DEFINE                                                                  02832000
FLLOCNAME   =FLAB#,           << local file name >>                     02834000
FLGRPNAME   =FLAB(4)#,        << group name >>                          02836000
FLACCTNAME  =FLAB(8)#,        << account name >>                        02838000
FLUSERID    =FLAB(12)#,       << creating user ID >>                    02840000
FLLOCKWORD  =FLAB(16)#,       << lockword >>                            02842000
FLSECMX     =FLABDBL(10)#,    << security matrix >>                     02844000
FLSECURE    =FLAB(22).(15:1)#,<< file Secure bit >>                     02846000
FLCREATE    =FLAB(23)#,       << create date >>                         02848000
FLLASTACC   =FLAB(24)#,       << last access date >>                    02850000
FLLASTMOD   =FLAB(25)#,       << last modification date >>              02852000
FLFILECODE  =FLAB(26)#,       << file code >>                           02854000
FLFCBVECT   =FLAB(27)#,       << FCB vector >>                          02856000
FLLOCK      =FLAB(28)#,       << lock bits, etc. >>                     02858000
FLSTORE     =FLAB(28).(0:1)#, << file being Stored >>                   02860000
FLRESTORE   =FLAB(28).(1:1)#, << file being Restored >>                 02862000
FLLOAD      =FLAB(28).(2:1)#, << file Loaded >>                         02864000
FLEXCL      =FLAB(28).(3:1)#, << exclusive FOPEN >>                     02866000
FLSR        =FLAB(28).(0:2)#, << Store & Restore bits >>                02868000
FLSRL       =FLAB(28).(0:3)#, << Store, Restore & Load bits >>          02870000
FLSRLX      =FLAB(28).(0:4)#, << Store, Restore, Load & Excl bits >>    02872000
FLSUBTYPE   =FLAB(28).(4:4)#, << sub type >>                            02874000
FLDTYPE     =FLAB(28).(8:6)#, << device type >>                         02876000
FLSTATUS    =FLAB(28).(14:2)#,<< Write/Read status >>                   02878000
FLUSERLBL   =FLAB(29)#,       << user label >>                          02880000
FLLBLEOF    =FLAB(29).(0:8)#, << # lbls written >>                      02882000
FLLBL       =FLAB(29).(8:8)#, << # of user labels >>                    02884000
FLFLIM      =FLABDBL(15)#,    << file limit >>                          02886000
FLPVINFO    =FLAB (33) #,     << PVINFO from mount >>          <<00188>>02888000
FLMVTABX    =FLPVINFO.(4:4) #,<< Mounted Vol Table index >>    <<00188>>02890000
FLCHECKSUM  =FLAB(34)#,       << file label checksum >>                 02892000
FLCLID      =FLAB(35)#,       << Cold Load ID >>                        02894000
FLFOPTIONS  =FLAB(36)#,       << FOPTIONS >>                            02896000
FLRECSIZE   =FLAB(37)#,       << record size, -bytes >>                 02898000
FLBLKSIZE   =FLAB(38)#,       << block size, words >>                   02900000
FLSECTOFF   =FLAB(39).(0:8)#, << sector offset to data >>               02902000
FLNUMEXTS   =FLAB(39).(11:5)#,<< number of extents - 1 >>               02904000
FLLASTEXTSIZE=FLAB(40)#,      << last extent size, sectors >>           02906000
FLEXTSIZE   =FLAB(41)#,       << extent size, sectors >>                02908000
FLEOF       =FLABDBL(21)#,    << end-of-data pointer, records >>        02910000
FLLABEL     =FLABDBL(22)#,    << file label VTAB and sector number >>   02912000
FLVTAB      =FLAB(44).(0:8)#, << file label VTAB index >>               02914000
FLEXTMAP    =FLAB(44)#,       << origin of Extent map >>                02916000
FLALLOCTIME =FLABDBL(54)#,    << Restore time >>               <<00630>>02918000
FLALLOCDATE =FLAB(110)#,      << Restore date >>               <<00630>>02920000
FLSTART     =FLABDBL(56)#,    << ABSOLUTE FIRST DATA BLOCK       HM.00>>02922000
FLEND       =FLABDBL(57)#,    << VAR LENGTH RECORDS ONLY - END   HM.00>>02924000
                              << NUMBER RELATIVE TO START BLOCK  HM.00>>02926000
FLHDRECS    =FLABDBL(58)#,    << NUMBER OF HEADER RECS >>      <<HM.00>>02928000
FLDEVNAME   =FLAB(124)#;      << device specification name >>           02930000
                                                                        02932000
DEFINE  <<FOPTIONS definitions>>                                        02934000
FLFILETYPE  = FLFOPTIONS.(2:3)#,      << FILE TYPE >>          <<HM.00>>02936000
FLKSAM      = (FLFILETYPE=1)#,        << RESERVED FOR KSAM >>  <<HM.00>>02938000
FLRIO       = (FLFILETYPE=2)#,        <<RIO FILE>>             <<HM.00>>02940000
FLCIRFILE   = (FLFILETYPE=4)#,        << CIRCULAR FILE >>      <<HM.00>>02942000
FLMSGFILE   = (FLFILETYPE=6)#,        << IPC FILE >>           <<HM.00>>02944000
FLNOEQUATE    = LOG(FLFOPTIONS.(5:1))#, << no file equation >>          02946000
FLUNLABELLED  = LOG(FLFOPTIONS.(6:1))#, << unlabelled tape >>           02948000
FLCONTROL     = LOG(FLFOPTIONS.(7:1))#, << carriage control >>          02950000
FLFORMAT      = FLFOPTIONS.(8:2)#,      << record format >>             02952000
FLVARFLD      = FLFOPTIONS.(9:1)#,      << variable bit >>              02954000
FLFIXED       = (FLFORMAT = 0)#,        << fixed >>                     02956000
FLVARIABLE    = (FLVARFLD = 1)#,        << variable >>                  02958000
FLNORMVAR     = (FLFORMAT = 1)#,        << normal var >>                02960000
FLSPECVAR     = (FLFORMAT = 3)#,        << special var >>               02962000
FLUNDEFINED   = (FLFORMAT = 2)#,        << undefined >>                 02964000
FLDESIGNATOR  = FLFOPTIONS.(10:3)#,     << designator type >>           02966000
FLACTUAL      = (FLDESIGNATOR = 0)#,    << actual >>                    02968000
FLSTDLIST     = (FLDESIGNATOR = 1)#,    << $STDLIST >>                  02970000
FLNEWPASS     = (FLDESIGNATOR = 2)#,    << $NEWPASS >>                  02972000
FLOLDPASS     = (FLDESIGNATOR = 3)#,    << $OLDPASS >>                  02974000
FLSTDIN       = (FLDESIGNATOR = 4)#,    << $STDIN >>                    02976000
FLSTDINX      = (FLDESIGNATOR = 5)#,    << $STDINX >>                   02978000
FLNULL        = (FLDESIGNATOR = 6)#,    << $NULL >>                     02980000
FLASCII       = LOG(FLFOPTIONS.(13:1))#,<< ASCII format >>              02982000
FLDOMAIN      = FLFOPTIONS.(14:2)#,     << file domain >>               02984000
FLNEW         = (FLDOMAIN = 0)#,        << new >>                       02986000
FLPERMANENT   = (FLDOMAIN = 1)#,        << old - permanent >>           02988000
FLTEMPORARY   = (FLDOMAIN = 2)#,        << old - temporary >>           02990000
FLOLD         = (FLDOMAIN = 3)#;        << old - either >>              02992000
                                                                        02994000
<<-------------------------------------------------------------  DS.00  02996000
*                                                             *  DS.00  02998000
*   REMOTE FILE ACCESS DEFINITIONS                            *  DS.00  03000000
*                                                             *  DS.00  03002000
---------------------------------------------------------------  DS.00>>03004000
                                                               <<DS.00>>03006000
EQUATE                                                         <<DS.00>>03008000
DSDUMMYDEV     = 41, << device type of DS dummy >>             <<DS.00>>03010000
RFAMSG         = 7,  << message type >>                        <<DS.00>>03012000
RFASTREAM      = %20,<< stream type >>                         <<DS.00>>03014000
RFASUBSTR      = 0;  << substream type >>                      <<DS.00>>03016000
                                                               <<DS.00>>03018000
DEFINE                                                         <<DS.00>>03020000
ALLOCRFABUF    = PUSH(S); @RFAPTR := TOS+1#,                   <<DS.00>>03022000
CC             = (6:2)#, << Cond. code bits of status >>       <<DS.00>>03024000
CHECKXFER      = IF <> THEN                                    <<DS.00>>03026000
                 BEGIN                                         <<DS.00>>03028000
                    TOS := 0;                                  <<DS.00>>03030000
                    TOS := RFALINE;                            <<DS.00>>03032000
                    TOS := DSCHKPLABEL;                        <<DS.00>>03034000
                    ASMB(PCAL 0);                              <<DS.00>>03036000
$                   IF X1 = ON                                 <<DS.00>>03038000
                    IF <> THEN FTROUBLE(486);                  <<KJ.03>>03040000
$                   IF                                         <<DS.00>>03042000
                    TOS := CCL;                                <<DS.00>>03044000
                    GO EXIT;                                   <<DS.00>>03046000
                 END#,                                         <<DS.00>>03048000
DELAPPENDAGE   = TOS := RFALEN-1; ASSEMBLE(SUBS 0)#,           <<DS.00>>03050000
FTYPE          = AFTE.(0:4)#, << file type from AFT >>         <<DS.03>>03052000
FTYPE'OF'TOS = TOS.(0:4)#,                                     <<+1.C3>>03054000
GETMWCPARMS    = TOS := 0;  TOS := RFALINE;  TOS := RFAMSG;    <<DS.00>>03056000
                 TOS := RFASTREAM;  TOS := RFASUBSTR;          <<DS.00>>03058000
                 TOS := @RFAPTR;  TOS := RFALEN#,              <<DS.00>>03060000
LOAD'ERROR    = TOS := TOS LOR LOCAL'FAILURE&LSL(8)#,          <<DS.04>>03062000
MWCNOBUF       = GETMWCPARMS;  TOS := 0D;  TOS := 0D;          <<DS.00>>03064000
                 TOS := MWCPLABEL;  ASMB(PCAL 0); DEL#,        <<DS.00>>03066000
DSCHKPLABEL    = ABS(DSCHKPLABL)#,                             <<DS.00>>03068000
DSOPENPLABEL   = ABS(DSOPENPLABL)#,                            <<DS.00>>03070000
DSCLOSEPLABEL  = ABS(DSCLOSEPLABL)#,                           <<DS.00>>03072000
MWCPLABEL      = ABS(MANWCPLABL)#,                             <<DS.00>>03074000
SDSLDEVPLABEL = ABS(SDSLDEVLABEL)#,                            <<DS.04>>03076000
PREPRETURN     = TOS := TOS.CC; ASSEMBLE(ZERO,XCH)#,           <<DS.00>>03078000
RFAFILE        = PACBV.(0:8)#,                                 <<DS.00>>03080000
RFALINE        = PACBV.(8:8)#,                                 <<DS.00>>03082000
RFAMREC        = LOGICAL(AFTE)#, << RFA Multi-rec file >>      <<DS.03>>03084000
SETRFAPTR      = DSTX := EXCHANGEDB(0);                        <<DS.00>>03086000
                 ALLOCRFABUF;                                  <<DS.00>>03088000
                 DSTX := EXCHANGEDB(DSTX)#;                    <<DS.00>>03090000
                                                               <<DS.00>>03092000
<<-------------------------------------------------------------  RV.PV  03094000
*                                                             *  RV.PV  03096000
*  DIRECTORY ENTRY DEFINITIONS                                *  RV.PV  03098000
*                                                             *  RV.PV  03100000
---------------------------------------------------------------  RV.PV>>03102000
                                                               <<RV.PV>>03104000
EQUATE                                                         <<RV.PV>>03106000
                                                               <<RV.PV>>03108000
   NAMESIZE        = 4,                                        <<RV.PV>>03110000
                                                               <<RV.PV>>03112000
<<Group entry>>                                                <<RV.PV>>03114000
   GNAME           = 0,                  <<name>>              <<RV.PV>>03116000
   GFIPNTR         = GNAME+NAMESIZE,     <<file index>>        <<RV.PV>>03118000
   GPASS           = GFIPNTR+1,          <<password>>          <<RV.PV>>03120000
   GDFSCOUNT       = GPASS+NAMESIZE,     <<disc file space>>   <<RV.PV>>03122000
   GDFSLIMIT       = GDFSCOUNT+2,                              <<RV.PV>>03124000
   GCPUCOUNT       = GDFSLIMIT+2,        <<CPU time>>          <<RV.PV>>03126000
   GCPULIMIT       = GCPUCOUNT+2,                              <<RV.PV>>03128000
   GCONTIMECOUNT   = GCPULIMIT+2,                              <<RV.PV>>03130000
   GCONTIMELIMIT   = GCONTIMECOUNT+2,                          <<RV.PV>>03132000
   GSEC            = GCONTIMELIMIT+2,                          <<RV.PV>>03134000
   GPURGEFLAGW     = GSEC,                                     <<RV.PV>>03136000
   GCAP            = GSEC +2,                                  <<RV.PV>>03138000
   GLINKAGE        = GCAP+1,                                   <<RV.PV>>03140000
   GVSDIPNTR       = GLINKAGE+1,         <<VS def index pntr>> <<RV.PV>>03142000
   GHVSNAME        = GVSDIPNTR+1,        <<Home VS name>>      <<RV.PV>>03144000
   GHVSANAME       = GHVSNAME,           << "   "  acct name>> <<RV.PV>>03146000
   GHVSGNAME       = GHVSANAME+NAMESIZE, << "   "  grp  name>> <<RV.PV>>03148000
   GHVSVSNAME      = GHVSGNAME+NAMESIZE, << "   "  VS   name>> <<RV.PV>>03150000
   GSAVEFIPNTR     = GHVSVSNAME+NAMESIZE,<<saves GFIPNTR>>     <<RV.PV>>03152000
   GMOUNTREFCNTR   = GSAVEFIPNTR+1,      <<mount use counter>> <<RV.PV>>03154000
   GSPARE          = GMOUNTREFCNTR+1,                          <<RV.PV>>03156000
   GSIZE           = GSPARE+1;                                 <<RV.PV>>03158000
<<GLINKAGE DEFINITIONS>>                                       <<RV.PV>>03160000
DEFINE                                                         <<RV.PV>>03162000
   PVF             = 0:1 #,                                    <<RV.PV>>03164000
   MVTABXF         = 8:8 #;                                    <<RV.PV>>03166000
EQUATE                                                         <<RV.PV>>03168000
   PV              = 1;                                        <<RV.PV>>03170000
<<----------------------------------------------------------------------03172000
*                                                                      *03174000
*  FORWARD PROCEDURE DECLARATIONS                                      *03176000
*                                                                      *03178000
---------------------------------------------------------------------->>03180000
                                                                        03182000
INTEGER PROCEDURE FCLEAR (ASCII,DADDR,SECTADDR,NUM);                    03184000
   VALUE ASCII,DADDR,SECTADDR,NUM;                                      03186000
   LOGICAL ASCII,DADDR,NUM;                                             03188000
   DOUBLE SECTADDR;                                                     03190000
   OPTION EXTERNAL;                                                     03192000
INTEGER PROCEDURE FLABIO(LDEV,SECT,FUNC,FLAB);                 <<00.06>>03194000
   VALUE   LDEV,SECT,FUNC;                                     <<00.06>>03196000
   INTEGER LDEV,FUNC;                                          <<00.06>>03198000
   DOUBLE  SECT;                                               <<00.06>>03200000
   INTEGER ARRAY FLAB;                                         <<00.06>>03202000
   OPTION  EXTERNAL;                                           <<00.06>>03204000
PROCEDURE FLABIOERR(FLAG,FN,FGA);                              <<00.06>>03206000
   VALUE   FLAG,FN,FGA;                                        <<00.06>>03208000
   LOGICAL FLAG;                                               <<00.06>>03210000
   INTEGER FN,FGA;                                             <<00.06>>03212000
   OPTION EXTERNAL,VARIABLE;                                   <<00.06>>03214000
PROCEDURE FREADLABEL(FN,TARGET,TCOUNT,LBL);                             03216000
   VALUE FN,TCOUNT,LBL;                                                 03218000
   INTEGER FN,TCOUNT,LBL;                                               03220000
   ARRAY TARGET;                                                        03222000
   OPTION FORWARD,VARIABLE;                                             03224000
PROCEDURE LDEVTOVTAB (TARGET,SOURCE,COUNT,LOCAL);              <<RV.PV>>03226000
   VALUE COUNT,LOCAL;                                          <<RV.PV>>03228000
   DOUBLE ARRAY TARGET,SOURCE;                                          03230000
   INTEGER COUNT;                                                       03232000
   LOGICAL LOCAL;                                              <<RV.PV>>03234000
   OPTION EXTERNAL;                                                     03236000
INTEGER PROCEDURE IOSTAT (STAT);                                        03238000
   VALUE STAT;                                                          03240000
   INTEGER STAT;                                                        03242000
   OPTION EXTERNAL;                                                     03244000
PROCEDURE FTROUBLE (CODE);                                              03246000
   VALUE CODE;                                                          03248000
   INTEGER CODE;                                                        03250000
   OPTION EXTERNAL;                                                     03252000
PROCEDURE FTITLE (T1,T2,T3,T4);                                         03254000
   VALUE T1,T2,T3,T4;                                                   03256000
   DOUBLE T1,T2,T3,T4;                                                  03258000
   OPTION EXTERNAL;                                                     03260000
DOUBLE PROCEDURE DISCSIZE(LDEV);                               <<01115>>03262000
   VALUE LDEV;                                                 <<01115>>03264000
   INTEGER LDEV;                                               <<01115>>03266000
   OPTION EXTERNAL;                                            <<01115>>03268000
PROCEDURE KWRITE(FILENUM,TARGET,TCOUNT);                       <<KS.00>>03270000
   VALUE FILENUM,TCOUNT;                                       <<KS.00>>03272000
   INTEGER FILENUM,TCOUNT;                                     <<KS.00>>03274000
   ARRAY TARGET;                                               <<KS.00>>03276000
   OPTION EXTERNAL;                                            <<KS.00>>03278000
INTEGER PROCEDURE KREADDIR(FILENUM,TARGET,TCOUNT,REC);         <<KS.00>>03280000
   VALUE FILENUM,TCOUNT,REC;                                   <<KS.00>>03282000
   INTEGER FILENUM,TCOUNT;                                     <<KS.00>>03284000
   DOUBLE REC;                                                 <<KS.00>>03286000
   ARRAY TARGET;                                               <<KS.00>>03288000
   OPTION EXTERNAL;                                            <<KS.00>>03290000
PROCEDURE KUPDATE(FILENUM,TARGET,TCOUNT);                      <<KS.00>>03292000
   VALUE FILENUM,TCOUNT;                                       <<KS.00>>03294000
   INTEGER FILENUM,TCOUNT;                                     <<KS.00>>03296000
   ARRAY TARGET;                                               <<KS.00>>03298000
   OPTION EXTERNAL;                                            <<KS.00>>03300000
PROCEDURE KSPACE(FILENUM,DISPLACEMENT);                        <<KS.00>>03302000
   VALUE FILENUM,DISPLACEMENT;                                 <<KS.00>>03304000
   INTEGER FILENUM,DISPLACEMENT;                               <<KS.00>>03306000
   OPTION EXTERNAL;                                            <<KS.00>>03308000
PROCEDURE KPOINT(FILENUM,RECNUM);                              <<KS.00>>03310000
   VALUE FILENUM,RECNUM;                                       <<KS.00>>03312000
   INTEGER FILENUM;                                            <<KS.00>>03314000
   DOUBLE RECNUM;                                              <<KS.00>>03316000
   OPTION EXTERNAL;                                            <<KS.00>>03318000
PROCEDURE KCONTROL(FILENUM,CODE,PARAM);                        <<KS.00>>03320000
   VALUE FILENUM,CODE;                                         <<KS.00>>03322000
   INTEGER FILENUM,CODE,PARAM;                                 <<KS.00>>03324000
   OPTION EXTERNAL;                                            <<KS.00>>03326000
PROCEDURE KSETMODE(FILENUM,FLAGS);                             <<KS.00>>03328000
   VALUE FILENUM,FLAGS;                                        <<KS.00>>03330000
   INTEGER FILENUM;                                            <<KS.00>>03332000
   LOGICAL FLAGS;                                              <<KS.00>>03334000
   OPTION EXTERNAL;                                            <<KS.00>>03336000
PROCEDURE KCHECK(FILENUM,ERRCODE,TLOG,BLKNUM,                  <<KS.00>>03338000
   NUMRECS);                                                   <<KS.00>>03340000
   VALUE FILENUM;                                              <<KS.00>>03342000
   INTEGER FILENUM,ERRCODE,TLOG,NUMRECS;                       <<KS.00>>03344000
   DOUBLE BLKNUM;                                              <<KS.00>>03346000
   OPTION EXTERNAL;                                            <<KS.00>>03348000
PROCEDURE KGETINFO(FILENUM,FILENAME,FOPTIONS,                  <<KS.00>>03350000
   AOPTIONS,RECSIZE,DEVTYPE,LDNUM,HDADDR,FILECODE,             <<KS.00>>03352000
   RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,BLKSIZE,               <<KS.00>>03354000
   EXTSIZE,NUMEXTENTS,USERLABELS,CREATORID,DISKADR);           <<KS.00>>03356000
   VALUE FILENUM;                                              <<KS.00>>03358000
   INTEGER FILENUM,RECSIZE,DEVTYPE,FILECODE,BLKSIZE,           <<KS.00>>03360000
   NUMEXTENTS,USERLABELS;                                      <<KS.00>>03362000
   BYTE ARRAY FILENAME,CREATORID;                              <<KS.00>>03364000
   LOGICAL FOPTIONS,AOPTIONS,LDNUM,HDADDR,EXTSIZE;             <<KS.00>>03366000
   DOUBLE RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,DISKADR;        <<KS.00>>03368000
   OPTION EXTERNAL,VARIABLE;                                   <<KS.00>>03370000
PROCEDURE KFILEINFO(FILENUM,ITEMNUM1,ITEMVAL1,                 <<04876>>03372000
                    ITEMNUM2,ITEMVAL2,ITEMNUM3,ITEMVAL3,       <<04876>>03374000
                    ITEMNUM4,ITEMVAL4,ITEMNUM5,ITEMVAL5);      <<04876>>03376000
   VALUE FILENUM,ITEMNUM1,ITEMNUM2,ITEMNUM3,ITEMNUM4,ITEMNUM5; <<04876>>03378000
   INTEGER FILENUM,ITEMNUM1,ITEMNUM2,ITEMNUM3,ITEMNUM4,        <<04876>>03380000
           ITEMNUM5;                                           <<04876>>03382000
   BYTE ARRAY ITEMVAL1,ITEMVAL2,ITEMVAL3,ITEMVAL4,ITEMVAL5;    <<04876>>03384000
   OPTION EXTERNAL,VARIABLE;                                   <<04876>>03386000
PROCEDURE KREADLABEL(FN,TARGET,TCOUNT,LBL);                    <<KS.00>>03388000
   VALUE FN,TCOUNT,LBL;                                        <<KS.00>>03390000
   INTEGER FN,TCOUNT,LBL;                                      <<KS.00>>03392000
   ARRAY TARGET;                                               <<KS.00>>03394000
   OPTION EXTERNAL;                                            <<KS.00>>03396000
PROCEDURE KWRITELABEL(FN,TARGET,TCOUNT,LBL);                   <<KS.00>>03398000
   VALUE FN,TCOUNT,LBL;                                        <<KS.00>>03400000
   INTEGER FN,TCOUNT,LBL;                                      <<KS.00>>03402000
   ARRAY TARGET;                                               <<KS.00>>03404000
   OPTION EXTERNAL;                                            <<KS.00>>03406000
PROCEDURE KLOCK(FN,T);                                         <<KS.00>>03408000
   VALUE FN,T;                                                 <<KS.00>>03410000
   INTEGER FN;                                                 <<KS.00>>03412000
   LOGICAL T;                                                  <<KS.00>>03414000
   OPTION EXTERNAL;                                            <<KS.00>>03416000
PROCEDURE KUNLOCK(FN);                                         <<KS.00>>03418000
   VALUE FN;                                                   <<KS.00>>03420000
   INTEGER FN;                                                 <<KS.00>>03422000
   OPTION EXTERNAL;                                            <<KS.00>>03424000
INTEGER PROCEDURE KREAD(FILENUM,TARGET,TCOUNT);                <<KS.00>>03426000
   VALUE FILENUM,TCOUNT;                                       <<KS.00>>03428000
   INTEGER FILENUM,TCOUNT;                                     <<KS.00>>03430000
   ARRAY TARGET;                                               <<KS.00>>03432000
   OPTION EXTERNAL;                                            <<KS.00>>03434000
PROCEDURE FCHECK(P1,P2,P3,P4,P5);                                       03436000
   VALUE P1;                                                            03438000
   INTEGER P1,P2,P3,P5;                                                 03440000
   DOUBLE P4;                                                           03442000
   OPTION VARIABLE,PRIVILEGED,FORWARD;                                  03444000
                                                                        03446000
<<----------------------------------------------------------------------03448000
*                                                                      *03450000
*  EXTERNAL PROCEDURE DECLARATIONS                                     *03452000
*                                                                      *03454000
---------------------------------------------------------------------->>03456000
                                                               <<03038>>03458000
PROCEDURE ABORT(MODE,CODE,PARAM);                              <<03038>>03460000
VALUE MODE,CODE,PARAM;                                         <<03038>>03462000
LOGICAL MODE,CODE,PARAM;                                       <<03038>>03464000
OPTION EXTERNAL;                                               <<03038>>03466000
                                                                        03468000
PROCEDURE ABORTIOX (IOQX);                                     <<+0.05>>03470000
   VALUE IOQX;                                                 <<+0.05>>03472000
   INTEGER IOQX;                                               <<+0.05>>03474000
   OPTION EXTERNAL;                                            <<+0.05>>03476000
                                                               <<04566>>03478000
DOUBLE PROCEDURE IOSTATUS(IOQX);                               <<04566>>03480000
VALUE IOQX;                                                    <<04566>>03482000
INTEGER IOQX;                                                  <<04566>>03484000
OPTION EXTERNAL,PRIVILEGED,UNCALLABLE;                         <<04566>>03486000
                                                               <<04566>>03488000
DOUBLE PROCEDURE ATTACHIO (LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS);  03490000
   VALUE LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS;                     03492000
   INTEGER LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS;                   03494000
   OPTION EXTERNAL;                                                     03496000
PROCEDURE AWAKE(PCBPT,CONDITION,WAITFLAG);                     <<HM.00>>03498000
VALUE PCBPT,CONDITION,WAITFLAG;                                <<HM.00>>03500000
INTEGER PCBPT,WAITFLAG;                                        <<HM.00>>03502000
LOGICAL CONDITION;                                             <<HM.00>>03504000
OPTION EXTERNAL;                                               <<HM.00>>03506000
                                                               <<HM.00>>03508000
INTEGER PROCEDURE CALENDAR;                                             03510000
   OPTION EXTERNAL;                                                     03512000
LOGICAL PROCEDURE CHANGEINTSTATE(NEWSTATE);                    <<03038>>03514000
   VALUE NEWSTATE;                                             <<03038>>03516000
   LOGICAL NEWSTATE;                                           <<03038>>03518000
   OPTION EXTERNAL;                                            <<03038>>03520000
PROCEDURE CLEARWAKE (IOQX);                                             03522000
   VALUE IOQX;                                                          03524000
   INTEGER IOQX;                                                        03526000
   OPTION EXTERNAL;                                                     03528000
PROCEDURE CLEARWWS;                                                     03530000
   OPTION EXTERNAL;                                                     03532000
                                                               <<TL.02>>03536000
INTEGER PROCEDURE CHECKUL(FN,CODE,FUNC);                       <<02693>>03538000
  VALUE FN,CODE,FUNC;                                          <<02545>>03540000
  INTEGER FN,CODE,FUNC;                                        <<02545>>03542000
  OPTION EXTERNAL;                                             <<TL.02>>03544000
                                                               <<TL.02>>03546000
PROCEDURE DEBUG;                                                        03550000
   OPTION EXTERNAL;                                                     03552000
LOGICAL PROCEDURE DEVICESTATUS (LDEV);                                  03554000
   VALUE LDEV;                                                          03556000
   INTEGER LDEV;                                                        03558000
   OPTION EXTERNAL;                                                     03560000
DOUBLE PROCEDURE DIRECADJUST (NUMSECTS,DUMMY,AN,GN,MVTABX);    <<39.PV>>03562000
   VALUE NUMSECTS,DUMMY,MVTABX;                                <<39.PV>>03564000
   DOUBLE NUMSECTS;                                                     03566000
   INTEGER DUMMY,MVTABX;                                       <<39.PV>>03568000
   ARRAY AN,GN;                                                         03570000
   OPTION EXTERNAL,VARIABLE;                                   <<39.PV>>03572000
INTEGER PROCEDURE DISKALLOC (INDEX,NUMEXT,SPACEDATA,PVINFO);   <<RH.PV>>03574000
   VALUE INDEX,NUMEXT,PVINFO;                                  <<RH.PV>>03576000
   INTEGER INDEX,NUMEXT;                                       <<RH.PV>>03578000
   LOGICAL PVINFO;                                             <<RH.PV>>03580000
   DOUBLE ARRAY SPACEDATA;                                              03582000
   OPTION EXTERNAL;                                                     03584000
   COMMENT  Returns operation status as result:                         03586000
      0 - OK                                                            03588000
      1 - Invalid number of sectors                                     03590000
      2 - Device not available (left byte contains LDEV)                03592000
      3 - Disc space not available                                      03594000
      4 - Misc. I/O error                                               03596000
      5 - Invalid index;                                                03598000
INTEGER PROCEDURE DISKDEALLOC (EXTSIZE,LASTEXTSIZE,NUMEXT,MAP);         03600000
   VALUE EXTSIZE,LASTEXTSIZE,NUMEXT;                                    03602000
   INTEGER EXTSIZE,LASTEXTSIZE,NUMEXT;                                  03604000
   DOUBLE ARRAY MAP;                                                    03606000
   OPTION EXTERNAL;                                                     03608000
   COMMENT  Returns operation status as result:                         03610000
      Left byte:                                                        03612000
         Map entry index                                                03614000
      Right byte:                                                       03616000
         0 - OK                                                         03618000
         1 - Misc. I/O error                                            03620000
         2 - Invalid number of sectors                                  03622000
         4 - Invalid sector number                                      03624000
         5 - Free space table full;                                     03626000
PROCEDURE ERROREXIT (WORDS,ERROR,ZERO);                                 03628000
   VALUE WORDS,ERROR,ZERO;                                              03630000
   INTEGER WORDS,ERROR,ZERO;                                            03632000
   OPTION EXTERNAL;                                                     03634000
PROCEDURE ERRORON;                                                      03636000
   OPTION EXTERNAL;                                                     03638000
LOGICAL PROCEDURE EXCHANGEDB (DSTX);                                    03640000
   VALUE DSTX;                                                          03642000
   LOGICAL DSTX;                                                        03644000
   OPTION EXTERNAL;                                                     03646000
INTEGER PROCEDURE FCCONTROL(FUNCTION,PARAMETER);               <<HM.00>>03648000
   VALUE FUNCTION;                                             <<HM.00>>03650000
   INTEGER FUNCTION;                                           <<HM.00>>03652000
   LOGICAL PARAMETER;                                          <<HM.00>>03654000
   OPTION EXTERNAL;                                            <<HM.00>>03656000
DOUBLE PROCEDURE FCHECKMSGBLOCK(TARGET,BC);                    <<HM.00>>03658000
   VALUE TARGET,BC;                                            <<HM.00>>03660000
   INTEGER POINTER TARGET;                                     <<HM.00>>03662000
   INTEGER BC;                                                 <<HM.00>>03664000
   OPTION EXTERNAL;                                            <<HM.00>>03666000
PROCEDURE FCREAD(FUNCTION,TARGET,TCOUNT);                      <<HM.00>>03668000
   VALUE FUNCTION,TARGET,TCOUNT;                               <<HM.00>>03670000
   INTEGER POINTER TARGET;                                     <<HM.00>>03672000
   INTEGER FUNCTION,TCOUNT;                                    <<HM.00>>03674000
   OPTION EXTERNAL;                                            <<HM.00>>03676000
PROCEDURE FCWRITE(FUNCTION,TARGET,TCOUNT);                     <<HM.00>>03678000
   VALUE FUNCTION,TARGET,TCOUNT;                               <<HM.00>>03680000
   INTEGER POINTER TARGET;                                     <<HM.00>>03682000
   INTEGER FUNCTION,TCOUNT;                                    <<HM.00>>03684000
   OPTION EXTERNAL;                                            <<HM.00>>03686000
INTEGER PROCEDURE FCWRITEOF(DUMMY1,DUMMY2);                    <<HM.00>>03688000
   VALUE DUMMY1,DUMMY2;                                        <<HM.00>>03690000
   INTEGER DUMMY1,DUMMY2;                                      <<HM.00>>03692000
   OPTION EXTERNAL;                                            <<HM.00>>03694000
INTEGER PROCEDURE FCABORTREQUESTS(DUMMY1,DUMMY2);              <<HM.00>>03696000
   VALUE DUMMY1,DUMMY2;                                        <<HM.00>>03698000
   INTEGER DUMMY1,DUMMY2;                                      <<HM.00>>03700000
   OPTION EXTERNAL;                                            <<HM.00>>03702000
PROCEDURE FCUPDATEWRITE(ACBLOC,NONDATARECORDS);                <<HM.00>>03704000
   VALUE ACBLOC,NONDATARECORDS;                                <<HM.00>>03706000
   INTEGER ACBLOC,NONDATARECORDS;                              <<HM.00>>03708000
   OPTION EXTERNAL;                                            <<HM.00>>03710000
PROCEDURE FCGETINFO(ACBLOC,INDEX,RETURNVALUE);                 <<03038>>03712000
VALUE ACBLOC,INDEX;                                            <<03038>>03714000
INTEGER ACBLOC,INDEX;                                          <<03038>>03716000
ARRAY RETURNVALUE;                                             <<03038>>03718000
OPTION EXTERNAL;                                               <<03038>>03720000
DOUBLE PROCEDURE FCRETURNINFO(RSIZE,ACBLOC);                   <<HM.00>>03722000
   VALUE RSIZE,ACBLOC;                                         <<HM.00>>03724000
   INTEGER RSIZE,ACBLOC;                                       <<HM.00>>03726000
   OPTION EXTERNAL;                                            <<HM.00>>03728000
LOGICAL PROCEDURE FCPORTENABLE(PORT'NUMBER);                   <<HM.00>>03730000
   VALUE PORT'NUMBER;                                          <<HM.00>>03732000
   INTEGER PORT'NUMBER;                                        <<HM.00>>03734000
   OPTION EXTERNAL;                                            <<HM.00>>03736000
PROCEDURE FCPORTDISABLE(PORT);                                 <<HM.00>>03738000
   VALUE PORT;                                                 <<HM.00>>03740000
   INTEGER PORT;                                               <<HM.00>>03742000
   OPTION EXTERNAL;                                            <<HM.00>>03744000
LOGICAL PROCEDURE FCCHECKFILEND(ACBLOC,BLOCKNUM);              <<01750>>03746000
   VALUE ACBLOC,BLOCKNUM;                                      <<01750>>03748000
   INTEGER ACBLOC;                                             <<01750>>03750000
   DOUBLE BLOCKNUM;                                            <<01750>>03752000
   OPTION EXTERNAL;                                            <<01750>>03754000
LOGICAL PROCEDURE GETSIR (SIRNUM);                                      03756000
   VALUE SIRNUM;                                                        03758000
   INTEGER SIRNUM;                                                      03760000
   OPTION EXTERNAL;                                                     03762000
PROCEDURE IMPEDE (PCBPT);                                               03764000
   VALUE PCBPT;                                                         03766000
   INTEGER PCBPT;                                                       03768000
   OPTION EXTERNAL;                                                     03770000
INTEGER PROCEDURE LDEVTODRT(LDEV);                             <<00157>>03772000
   VALUE LDEV;                                                 <<00157>>03774000
   LOGICAL LDEV;                                               <<00157>>03776000
   OPTION EXTERNAL;                                            <<00157>>03778000
INTEGER PROCEDURE LDEVTOSUBTYPE(LDEV);                         <<01115>>03780000
   VALUE LDEV;                                                 <<01115>>03782000
   INTEGER LDEV;                                               <<01115>>03784000
   OPTION EXTERNAL;                                            <<01115>>03786000
INTEGER PROCEDURE LDEVTOTYPE(LDEV);                            <<01115>>03788000
   VALUE LDEV;                                                 <<01115>>03790000
   INTEGER LDEV;                                               <<01115>>03792000
   OPTION EXTERNAL;                                            <<01115>>03794000
PROCEDURE MMSTAT (EVENT,P1,P2,P3);                             <<+0.04>>03796000
   VALUE EVENT,P1,P2,P3;                                       <<+0.04>>03798000
   INTEGER EVENT,P1,P2,P3;                                     <<+0.04>>03800000
   OPTION EXTERNAL;                                            <<+0.04>>03802000
LOGICAL PROCEDURE MRCAPOK (SB, RIN);                           <<00560>>03804000
  VALUE SB, RIN;                                               <<00560>>03806000
  LOGICAL SB;                                                  <<00560>>03808000
  INTEGER RIN;                                                 <<00560>>03810000
  OPTION VARIABLE, EXTERNAL;                                   <<00560>>03812000
INTEGER PROCEDURE REELSWITCH(LDEV,RDWR);                       <<02545>>03814000
   VALUE LDEV,RDWR;                                            <<02545>>03816000
   LOGICAL LDEV;                                               <<02545>>03818000
   INTEGER RDWR;                                               <<02545>>03820000
  OPTION EXTERNAL;                                             <<TL.02>>03822000
PROCEDURE RELSIR (SIRNUM,A);                                            03824000
   VALUE SIRNUM,A;                                                      03826000
   INTEGER SIRNUM;                                                      03828000
   LOGICAL A;                                                           03830000
   OPTION EXTERNAL;                                                     03832000
DOUBLE PROCEDURE REQSTATUS(LDN);                               <<01115>>03834000
   VALUE LDN; INTEGER LDN;                                     <<01115>>03836000
   OPTION EXTERNAL;                                            <<01115>>03838000
PROCEDURE RESETCRITICAL (OLDVAL);                                       03840000
   VALUE OLDVAL;                                                        03842000
   LOGICAL OLDVAL;                                                      03844000
   OPTION EXTERNAL;                                                     03846000
PROCEDURE RLOCK (RIN,T);                                                03848000
   VALUE RIN,T;                                                         03850000
   INTEGER RIN;                                                         03852000
   LOGICAL T;                                                           03854000
   OPTION EXTERNAL;                                                     03856000
PROCEDURE RUNLOCK (RIN);                                                03858000
   VALUE RIN;                                                           03860000
   INTEGER RIN;                                                         03862000
   OPTION EXTERNAL;                                                     03864000
LOGICAL PROCEDURE SETCRITICAL;                                          03866000
   OPTION EXTERNAL;                                                     03868000
PROCEDURE SETWAKE (IOQX);                                               03870000
   VALUE IOQX;                                                          03872000
   INTEGER IOQX;                                                        03874000
   OPTION EXTERNAL;                                                     03876000
PROCEDURE UNIMPEDE (PCBPT);                                             03878000
   VALUE PCBPT;                                                         03880000
   INTEGER PCBPT;                                                       03882000
   OPTION EXTERNAL;                                                     03884000
PROCEDURE WAIT (WF,JPCNTX);                                             03886000
   VALUE WF,JPCNTX;                                                     03888000
   INTEGER WF,JPCNTX;                                                   03890000
   OPTION EXTERNAL;                                                     03892000
                                                               <<04333>>03894000
LOGICAL PROCEDURE VALIDDEVTYPE (LDEV, FUNCTION, FLAGS);        <<04333>>03896000
   VALUE LDEV, FUNCTION;                                       <<04333>>03898000
   INTEGER LDEV, FUNCTION;                                     <<04333>>03900000
   LOGICAL FLAGS;                                              <<04333>>03902000
   OPTION EXTERNAL;                                            <<04333>>03904000
                                                               <<04333>>03906000
PROCEDURE FCAWAKEN(PIN);                                       <<03038>>03908000
VALUE PIN;                                                     <<03038>>03910000
INTEGER PIN;                                                   <<03038>>03912000
OPTION EXTERNAL;                                               <<03038>>03914000
DOUBLE PROCEDURE WAITFORIO (IOQX);                                      03916000
   VALUE IOQX;                                                          03918000
   INTEGER IOQX;                                                        03920000
   OPTION EXTERNAL;                                                     03922000
DOUBLE PROCEDURE WAITFORIOX (IOQX);                                     03924000
   VALUE IOQX;                                                          03926000
   INTEGER IOQX;                                                        03928000
   OPTION EXTERNAL;                                                     03930000
PROCEDURE TGETINFO(LDEV,FBUF,ITEMNUM);                         <<02545>>03934000
   VALUE LDEV,ITEMNUM; INTEGER LDEV,ITEMNUM;                   <<02545>>03936000
   ARRAY FBUF;                                                 <<02545>>03938000
   OPTION EXTERNAL;                                            <<02545>>03940000
                                                               <<TL.02>>03942000
DOUBLE PROCEDURE XDDSPOOLINFO (DVAL,ITEM,XDDSUBP);                      03944000
   VALUE   DVAL,ITEM,XDDSUBP;                                           03946000
   LOGICAL ITEM;                                                        03948000
   DOUBLE  DVAL;                                                        03950000
   INTEGER POINTER XDDSUBP;                                             03952000
   OPTION EXTERNAL;                                                     03954000
PROCEDURE QUEUEONSEGMENT(SEGID);                               <<01701>>03956000
   VALUE SEGID;                                                <<01701>>03958000
   INTEGER SEGID;                                              <<01701>>03960000
   OPTION EXTERNAL;                                            <<01701>>03962000
                                                                        03964000
 PROCEDURE HELP  << for dummy call >>;                         <<00117>>03966000
    OPTION EXTERNAL;                                           <<00117>>03968000
                                                               <<04776>>03970000
LOGICAL PROCEDURE STACKCHECK(DST'NUM);                         <<04776>>03972000
VALUE DST'NUM;INTEGER DST'NUM;                                 <<04776>>03974000
                                                               <<04776>>03976000
<<**********************************************************>> <<04776>>03978000
<< STACKCHECK will retrun true if the DST sent is a stack,  >> <<04776>>03980000
<< any stack, not necessarily our own.                      >> <<04776>>03982000
<<**********************************************************>> <<04776>>03984000
                                                               <<04776>>03986000
OPTION EXTERNAL;                                               <<04776>>03988000
                                                               <<04776>>03990000
$PAGE " GENERAL CONTROL BLOCK LOCKING "                                 03992000
$CONTROL SEGMENT = FILESYS1A  << LOCK'CB, UNLOCK'CB >>                  03994000
PROCEDURE                                                               03996000
   LOCK'CB(FLAGS,STACKDST,STK'TARGET,CBDST,CBOFST);                     03998000
   VALUE   FLAGS,STACKDST,STK'TARGET,CBDST,CBOFST;                      04000000
   INTEGER FLAGS,STACKDST,STK'TARGET,CBDST,CBOFST;                      04002000
   OPTION PRIVILEGED,UNCALLABLE;                                        04004000
                                                                        04006000
COMMENT  This procedure locks a control block using MDS instructions.   04008000
It returns four words (via partial cutback of the stack) suitable       04010000
for a MDS to copy the CB into a buffer of the calling procedure.  The   04012000
top two words will be CBDST and CBOFST (address of start of control     04014000
block data area) so TOS upon return must be incremented in order to     04016000
start copying from the middle of the control block.  A word count needs 04018000
to be pushed upon return and a MDS executed to read the control block.  04020000
                                                                        04022000
A special feature is the treatment used if FLAGS = 8.  This is a request04024000
for a "quick mode" lock, which, if granted, will cause the procedure    04026000
to return with the system P'disabled.  This will allow the calling      04028000
procedure to copy in data without actually setting the locked state     04030000
in the CB lock area.  This saves both a MDS back of the 3 lock words    04032000
as well as a call to UNLOCK'CB.  This strategy is suitable if the       04034000
control block needs to be locked for only a millisecond or so and there 04036000
can be no absence traps (either code or data).  In practice, this       04038000
requires that this option (FLAG = 8) only be called from a procedure    04040000
in the same segment as LOCK'CB.  An example is updating EOF in the      04042000
FCB.  It is possible that such a request for quick mode cannot be       04044000
satisfied (because the CB is locked and an IMPEDE was required).        04046000
Therefore the value of the FLAG parameter upon return is used to        04048000
inform the caller whether an UNLOCK'CB needs to be done ( FLAG=TRUE     04050000
means need UNLOCK'CB ).  The lowest parameter is used to pass back      04052000
this information rather than the condition code since often             04054000
several instructions need to be executed before testing whether         04056000
to call UNLOCK'CB.                                                      04058000
                                                               <<04558>>04060000
Another special feature is that of a conditional lock.  If the <<04558>>04062000
conditional lock bit has been set by LOC'ACB (FLAGS.(1:1) = 1),<<04558>>04064000
then we don't impede the process on a locked control block.    <<04558>>04066000
Instead, we leave him PSEUDO-DISABLED on the control block     <<04558>>04068000
queue and return.  LOC'ACB does this to release any SIR that   <<04558>>04070000
the process may have before impeding on the control block so   <<04558>>04072000
that system resources (namely the FMAVT SIR) are free.         <<04558>>04074000
                                                               <<04558>>04076000
                                                                        04078000
All potentially sharable FCB'S and ACB's will be in extra      <<04776>>04080000
data segments.  If the control block requested is in another   <<04776>>04082000
process's stack, the FOPON is calling us to obtain the FCB for <<04776>>04084000
checking.  The FOPEN WILL FAIL and the file MUST HAVE          <<04776>>04086000
BEEN OPENED EXCLUSIVE.                                         <<04776>>04088000
                                                                        04090000
         Input variables, and output values:                            04092000
                                                                        04094000
FLAGS       =  bit 14 -- create break mode [FBREAK]                     04096000
               bit 12 -- request for "quick mode"                       04098000
               bit  1 -- conditional lock                      <<04558>>04100000
   Returned TRUE if UNLOCK'CB is needed.                                04102000
STACKDST    =  Ignored - DST of the stack returned.                     04104000
STK'TARGET  =  Caller's Q-relative CB buffer address.                   04106000
   Returned as stack-DST-relative address, for MDS.                     04108000
CBDST       =  DST of control block. Returned as supplied.              04110000
CBOFST      =  CB-table-relative offset of lock words, i.e. VT addr.    04112000
      This does not include the PX'CBTAB adjustment needed              04114000
      if the CBT is in the stack.                                       04116000
   Returned: the DST-relative address of the control block, with        04118000
   the PX'CBTAB adjustment included if needed.                          04120000
                                                               <<04558>>04122000
NOCARRY - Succesful                                            <<04558>>04124000
CARRY   - Conditional lock (Queued, no impede)                 <<04558>>04126000
                                                               <<04558>>04128000
                                                                        04130000
;                                                                       04132000
$PAGE                                                                   04134000
BEGIN                                                                   04136000
<< Do not add any variables before  the VT entry variables. >> <<04776>>04138000
INTEGER VT'ADDR;     << These four words get the VT entry. >>           04140000
LOGICAL CBL';                                                           04142000
   DOUBLE EASY'CASE = CBL';                                             04144000
INTEGER CBL'01;                                                         04146000
   INTEGER CBL'QUEUE = CBL'01;                                          04148000
INTEGER CBL'02;                                                         04150000
   INTEGER CBL'SAVEDQUEUE = CBL'02;                                     04152000
LOGICAL PIN,CARRY'SET;                                         <<04558>>04154000
INTEGER PX'CBTAB;  << Stack-DST-relative addr of PXFILE CBTAB >>        04156000
INTEGER Q'0'A;     << Stack-DST-rel. addr of Q+0 for this proc.>>       04158000
INTEGER                                                        <<04776>>04160000
   DSTX,           << DST of users buffer, current DST.     >> <<04776>>04162000
   PX'FILE,        << Segment offset of PXFILE area.        >> <<04776>>04164000
   Q'REL'DL,       << Q relative offset of DL.              >> <<04776>>04166000
   DL'DSEG'OFFSET; << Offset of DL from begining of stack.  >> <<04776>>04168000
LOGICAL                                                        <<04776>>04170000
   CB'IN'STACK;    << True if CB in any stack.              >> <<04776>>04172000
INTEGER POINTER                                                <<04776>>04174000
   DL'DSEG'PNTR,   << Points to DL in another PIN's stack.  >> <<04776>>04176000
   PCBX;           << Points to PCBX in another PIN's stack.>> <<04776>>04178000
                                                                        04180000
DEFINE CBL'BREAK = CBL'.(1:1)#;                                         04182000
DEFINE CBL'COUNT = CBL'.(2:6)#;                                         04184000
DEFINE CBL'PIN   = CBL'.(8:8)#;                                         04186000
DEFINE                                                         <<04558>>04188000
   QUICK'LOCK    = FLAGS.(12:1)=1#,                            <<04776>>04190000
   FBREAK'MODE   = FLAGS.(14:1)=1#,                            <<04776>>04192000
   COND'LOCK     = FLAGS.(1:1)=1#,                             <<04558>>04194000
   SETCARRY      = CARRYCODE :=1#,                             <<04558>>04196000
   SETNOCARRY    = CARRYCODE :=0#;                             <<04558>>04198000
                                                                        04200000
   <<*******************************************************>> <<04776>>04202000
   << First, obtain our stack DST number and calculate the  >> <<04776>>04204000
   << offset from DL to Q.                                  >> <<04776>>04206000
   <<*******************************************************>> <<04776>>04208000
                                                                        04210000
   CARRY'SET := FALSE; << Normal case, no conditional lock  >> <<04558>>04212000
   PIN := GETPROCNUM;                                                   04214000
   STACKDST := PCB'STK;                                        <<04776>>04216000
   PUSH(DL,Q);                                                          04218000
   ASMB(XCH,SUB);            << get DL-Q >>                             04220000
   X := TOS;                                                            04222000
   Q'0'A := AQM1(X)-X;       << (DL-a)-(DL-Q) >>                        04224000
   << Store Q relative offset to DL from X.                 >> <<04776>>04226000
   Q'REL'DL := X;                                              <<04776>>04228000
                                                               <<04776>>04230000
   <<*******************************************************>> <<04776>>04232000
   << Determine the DST relative offset of the beginning    >> <<04776>>04234000
   << of the control block area.  It is different if in an  >> <<04776>>04236000
   << extra data segment, our stack or another PIN's stack. >> <<04776>>04238000
   <<*******************************************************>> <<04776>>04240000
                                                               <<04776>>04242000
   CB'IN'STACK := FALSE;                                       <<04776>>04244000
   IF STACKCHECK(CBDST) THEN                                   <<04776>>04246000
      BEGIN             << Control Block is in a stack.     >> <<04776>>04248000
      CB'IN'STACK := TRUE;                                     <<04776>>04250000
      IF CBDST = STACKDST THEN                                 <<04776>>04252000
         BEGIN          << CB is in OUR stack.              >> <<04776>>04254000
         PX'FILE := AQM1(Q'REL'DL) - AQM3(Q'REL'DL);           <<04776>>04256000
         END                                                   <<04776>>04258000
      ELSE                                                     <<04776>>04260000
         BEGIN          << CB is in ANOTHER stack.          >> <<04776>>04262000
         DSTX := EXCHANGEDB(CBDST);  << Set DB to other stk.>> <<04776>>04264000
         @PCBX := 0;    << Point to his PCBX area.          >> <<04776>>04266000
         DL'DSEG'OFFSET := PCBX(0);  << 1st wrd is DL offset>> <<04776>>04268000
         @DL'DSEG'PNTR  := DL'DSEG'OFFSET;                     <<04776>>04270000
         PX'FILE := DL'DSEG'OFFSET - DL'DSEG'PNTR(-3);         <<04776>>04272000
         EXCHANGEDB(DSTX);           << Back to original.   >> <<04776>>04274000
         END;                                                  <<04776>>04276000
      << Don't forget to add the PXFILE overhead.           >> <<04776>>04278000
      PX'CBTAB := PX'FILE + PXFOVERHEAD;                       <<04776>>04280000
      END;                                                     <<04776>>04282000
                                                               <<04776>>04284000
   <<*******************************************************>> <<04776>>04286000
   << Now copy the Vector Table entry into our Q relative   >> <<04776>>04288000
   << locations.                                            >> <<04776>>04290000
   <<*******************************************************>> <<04776>>04292000
                                                               <<04776>>04294000
   TOS := STACKDST;         << Our stack DST number.        >> <<04776>>04296000
   TOS := Q'0'A + 1;        << @VT'ADDR, DST relative.      >> <<04776>>04298000
   TOS := CBDST;            << Control Block DST number.    >> <<04776>>04300000
   TOS := CBOFST;           << CB rel. offset of VT entry.  >> <<04776>>04302000
   IF CB'IN'STACK THEN                                         <<04776>>04304000
      TOS := TOS+PX'CBTAB;  << Add PX offset if in a stack. >> <<04776>>04306000
   TOS := VTENTRY;          << Size of vector table entry.  >> <<04776>>04308000
                                                                        04310000
   <<*******************************************************>> <<04776>>04312000
   << Make sure that the needed data segment is in memory   >> <<04776>>04314000
   << before P-disableing.  Test bit one, word zero of the  >> <<04776>>04316000
   << DST entry.  If off, then the DST is not present.      >> <<04776>>04318000
   <<*******************************************************>> <<04776>>04320000
                                                                        04322000
AGAIN:                                                                  04324000
   DISABLE;                                                             04326000
                                                               <<04776>>04328000
   IF DST'(CBDST*DSTENTRY + 0).(0:1) = 1 THEN                  <<04776>>04330000
      BEGIN          << Not present. >>                                 04332000
      ENABLE;                                                           04334000
      QUEUEONSEGMENT(CBDST);                                   <<01701>>04336000
      GOTO AGAIN;    << Hope the damned thing stays put. >>             04338000
      END;                                                              04340000
                                                                        04342000
   PSEUDODISABLE;    << Aha! Gotcha. >>                                 04344000
   ENABLE;                                                              04346000
   MOVE'DS'1;        << get 4 control words to VTADDR-CBL02 >>          04348000
   TOS := TOS-3;     << fix CBOFST >>                                   04350000
   ASMB(DXCH);                                                          04352000
   TOS := TOS-3;     << fix stack offset >>                             04354000
   TOS := 3;         << new word count >>                               04356000
      << Now TOS has the proper values for a MDS instruction            04358000
      to write back the three lock words.     >>                        04360000
                                                                        04362000
                                                                        04364000
   IF NOT (9 <= VT'ADDR <= FSEGMAX) THEN FTROUBLE(59);                  04366000
   TOS := EASY'CASE;      << test CBLCONTROL and CBLQUEUE >>            04368000
   DDEL;                                                                04370000
   IF = THEN                                                            04372000
      BEGIN             << CB wasn't locked - easy case >>              04374000
      IF QUICK'LOCK THEN                                       <<04776>>04376000
         BEGIN              << Short request. >>                        04378000
         TOS := FALSE;      << Exit P-disabled; unlock not needed. >>   04380000
         END                                                            04382000
      ELSE                                                              04384000
         BEGIN                                                          04386000
         IF FBREAK'MODE THEN                                   <<04776>>04388000
            TOS := %140400     << Lock, break, count=1 >>               04390000
         ELSE                                                           04392000
            TOS := %100400;    << Lock; count=1 >>                      04394000
         GO LW;                                                         04396000
         END                                                            04398000
      END                   << end of easy case >>                      04400000
   ELSE                                                                 04402000
      BEGIN                 << Hard case >>                             04404000
      TOS := CBL';           << control word >>                         04406000
      IF < THEN     << already locked by someone. >>                    04408000
         IF TOS.(8:8) = PIN THEN                                        04410000
            BEGIN        << Already locked by our process. >>           04412000
            CBL'COUNT := CBL'COUNT+1;  << bump lock count >>            04414000
            IF CBL'COUNT=0 THEN FTROUBLE(457);   << overflow >>         04416000
            GO LX;                                                      04418000
            END                                                         04420000
         ELSE                                                           04422000
            BEGIN        << Locked by different process. >>             04424000
            IF FBREAK'MODE THEN                                <<04776>>04426000
               BEGIN         << Create break queue >>                   04428000
               CBL'BREAK := 1;  << set Break mode bit >>                04430000
               IF = THEN                                                04432000
                  BEGIN         << Was not in break mode. >>            04434000
                  CBL'SAVEDQUEUE := CBL'QUEUE;   << save impeded >>     04436000
                  CBL'QUEUE := 0        << set impeded queue empty >>   04438000
                  END;                                                  04440000
               END;                                                     04442000
            IF CBL'BREAK AND PCB'PTYPE = 0 THEN                         04444000
L1:            TOS := CBL'SAVEDQUEUE     << low priority >>             04446000
            ELSE                                                        04448000
               TOS := CBL'QUEUE;     << high or regular priority >>     04450000
                                                                        04452000
            IF = THEN                                                   04454000
               TOS := TOS+PIN   << Was empty. We're at head of queue >> 04456000
            ELSE              << Wasn't empty. Go to end of queue >>    04458000
               PCB(S0.(0:8)*PCBSIZE+8).(8:8) := PIN;                    04460000
                                                                        04462000
            TOS.(0:8) := PIN;     << Tail PIN >>                        04464000
                                                                        04466000
            IF CBL'BREAK AND PCB'PTYPE = 0 THEN                         04468000
               CBL'SAVEDQUEUE := TOS     << low pri >>                  04470000
            ELSE  CBL'QUEUE := TOS;   << high/reg priority >>           04472000
                                                                        04474000
            PCB'IQPTR := 0;       << my link >>                         04476000
            MOVE'DS'5;            << post updated lock words >>         04478000
                                                               <<04558>>04480000
            <<**********************************************>> <<04558>>04482000
            << If we want a conditional lock, then set the  >> <<04558>>04484000
            << CARRY bit and go on, don't impede the process>> <<04558>>04486000
            <<**********************************************>> <<04558>>04488000
                                                               <<04558>>04490000
            IF COND'LOCK                                       <<04558>>04492000
               THEN CARRY'SET := TRUE << Queued, P-disabled >> <<04558>>04494000
               ELSE IMPEDE(0);  <<Will reture P-enabled     >> <<04558>>04496000
                                                               <<04558>>04498000
                                                                        04500000
    << Sleep, until our turn comes up. >>                               04502000
                                                                        04504000
            TOS := TRUE;          << really locked >>                   04506000
            GO LZ;                                                      04508000
            END           << different process >>                       04510000
      ELSE                                                              04512000
         BEGIN               << Not locked >>                           04514000
         IF LOGICAL(TOS.(1:1)) THEN                                     04516000
            BEGIN                 << In Break mode >>                   04518000
            IF PCB'PTYPE = 0 THEN GO L1;    << low pri >>               04520000
            TOS := %140400;       << Locked; count=1, break >>          04522000
            END                                                         04524000
         ELSE                                                           04526000
            TOS := %100400;       << Locked; count=1 >>                 04528000
LW:      CBL' := TOS+PIN;         << update control word >>             04530000
         END;       << not locked >>                                    04532000
LX:                                                                     04534000
      MOVE'DS'5;        << write back 3 lock words >>                   04536000
      PSEUDOENABLE;                                                     04538000
      TOS := TRUE;          << really locked >>                         04540000
      END;                  << end of hard case >>                      04542000
LZ:                                                                     04544000
   FLAGS := TOS;                                                        04546000
   TOS := VT'ADDR;                                                      04548000
   IF CB'IN'STACK THEN                                         <<04776>>04550000
      TOS := TOS + PX'CBTAB;                                            04552000
   CBOFST := TOS;       << DST-rel CB address >>                        04554000
   STK'TARGET := STK'TARGET+Q'0'A-DELTAQ;  << make stk-DST rel.>>       04556000
                                                               <<04558>>04558000
   << Set CARRY based on conditional lock flag.             >> <<04558>>04560000
                                                               <<04558>>04562000
   IF CARRY'SET                                                <<04558>>04564000
      THEN SETCARRY    << Conditional lock                  >> <<04558>>04566000
      ELSE SETNOCARRY; << Normal case, no conditional lock  >> <<04558>>04568000
                                                               <<04558>>04570000
   RETURN 0;                  << pop marker only >>                     04572000
                                                                        04574000
   END;     << procedure LOCK'CB >>                                     04576000
$PAGE                                                          <<04776>>04578000
                                                                        04580000
PROCEDURE UNLOCK'CB(FLAGS,CBDST,CBOFST);                                04582000
VALUE FLAGS,CBDST,CBOFST;                                               04584000
INTEGER FLAGS,CBDST,CBOFST;                                             04586000
OPTION PRIVILEGED,UNCALLABLE;                                           04588000
                                                                        04590000
<< Unlocks the specified control block.  If no one is queued            04592000
up waiting for it and we don't have to fiddle with break                04594000
queues, we can just clear the lockword and leave.                       04596000
                                                                        04598000
   Input variables:                                                     04600000
FLAGS  = flag word                                                      04602000
  (13:1) = destroy Break queue [FUNBREAK]                               04604000
  (14:1) = create Break queue [IOMOVE (terminal, NOBUF)]                04606000
CBDST    =  DST of control block.                                       04608000
CBOFST   = CB-table-relative offset of lock words, i.e. VT addr.        04610000
                   >>                                                   04612000
                                                                        04614000
BEGIN                                                                   04616000
INTEGER VT'ADDR;     << These four words get the VT entry. >>           04618000
LOGICAL CBL';                                                           04620000
   DOUBLE EASY'CASE = CBL';                                             04622000
INTEGER CBL'01;                                                         04624000
   INTEGER CBL'QUEUE = CBL'01;                                          04626000
INTEGER CBL'02;                                                         04628000
   INTEGER CBL'SAVEDQUEUE = CBL'02;                                     04630000
LOGICAL PIN;                                                            04632000
INTEGER PX'CBTAB;  << Stack-DST-relative addr of PXFILE CBTAB >>        04634000
INTEGER STACKDST;                                                       04636000
INTEGER Q'0'A;     << Stack-DST-rel. addr of Q+0 for this proc.>>       04638000
INTEGER                                                        <<04776>>04640000
   DSTX,           << DST of users buffer, current DST.     >> <<04776>>04642000
   PX'FILE,        << Segment offset of PXFILE area.        >> <<04776>>04644000
   Q'REL'DL,       << Q relative offset of DL.              >> <<04776>>04646000
   DL'DSEG'OFFSET; << Offset of DL from begining of stack.  >> <<04776>>04648000
LOGICAL                                                        <<04776>>04650000
   CB'IN'STACK;    << True if CB in any stack.              >> <<04776>>04652000
INTEGER POINTER                                                <<04776>>04654000
   DL'DSEG'PNTR,   << Points to DL in another PIN's stack.  >> <<04776>>04656000
   PCBX;           << Points to PCBX in another PIN's stack.>> <<04776>>04658000
                                                                        04660000
DEFINE CBL'BREAK = CBL'.(1:1)#;                                         04662000
DEFINE CBL'COUNT = CBL'.(2:6)#;                                         04664000
DEFINE CBL'PIN   = CBL'.(8:8)#;                                         04666000
DEFINE                                                         <<04776>>04668000
   FUNBREAK'MODE     = FLAGS.(13:1)=1#,                        <<04776>>04670000
   CREATE'BREAK'MODE = FLAGS.(14:1)=1#;                        <<04776>>04672000
                                                                        04674000
   <<*******************************************************>> <<04776>>04676000
   << First, obtian our stack DST number and calculate the  >> <<04776>>04678000
   << Q-relative offset of DL .                             >> <<04776>>04680000
   <<*******************************************************>> <<04776>>04682000
                                                                        04684000
   PIN := GETPROCNUM;                                                   04686000
   STACKDST := PCB'STK;                                        <<04776>>04688000
   PUSH(DL,Q);                                                          04690000
   ASMB(XCH,SUB);            << get DL-Q >>                             04692000
   X := TOS;                                                            04694000
   Q'0'A := AQM1(X)-X;       << (DL-a)-(DL-Q) >>                        04696000
   Q'REL'DL := X;            << Save Q-relalative DL from X >> <<04776>>04698000
                                                               <<04776>>04700000
   <<*******************************************************>> <<04776>>04702000
   << Determine the DST relative offset of the beginning    >> <<04776>>04704000
   << of the control block area.  It is different if in an  >> <<04776>>04706000
   << extra data segment, our stack or another PIN's stack. >> <<04776>>04708000
   <<*******************************************************>> <<04776>>04710000
                                                               <<04776>>04712000
   CB'IN'STACK := FALSE;                                       <<04776>>04714000
   IF STACKCHECK(CBDST) THEN                                   <<04776>>04716000
      BEGIN             << Control Block is in a stack.     >> <<04776>>04718000
      CB'IN'STACK := TRUE;                                     <<04776>>04720000
      IF CBDST = STACKDST THEN                                 <<04776>>04722000
         BEGIN          << CB is in OUR stack.              >> <<04776>>04724000
         PX'FILE := AQM1(Q'REL'DL) - AQM3(Q'REL'DL);           <<04776>>04726000
         END                                                   <<04776>>04728000
      ELSE                                                     <<04776>>04730000
         BEGIN          << CB is in ANOTHER stack.          >> <<04776>>04732000
         DSTX := EXCHANGEDB(CBDST);  << Set DB to other stk.>> <<04776>>04734000
         @PCBX := 0;    << Point to his PCBX area.          >> <<04776>>04736000
         DL'DSEG'OFFSET := PCBX(0);  << 1st wrd is DL offset>> <<04776>>04738000
         @DL'DSEG'PNTR  := DL'DSEG'OFFSET;                     <<04776>>04740000
         PX'FILE := DL'DSEG'OFFSET - DL'DSEG'PNTR(-3);         <<04776>>04742000
         EXCHANGEDB(DSTX);           << Back to original.   >> <<04776>>04744000
         END;                                                  <<04776>>04746000
      << Don't forget to add the PXFILE overhead.           >> <<04776>>04748000
      PX'CBTAB := PX'FILE + PXFOVERHEAD;                       <<04776>>04750000
      END;                                                     <<04776>>04752000
                                                               <<04776>>04754000
   <<*******************************************************>> <<04776>>04756000
   << Now copy the Vector Table entry into our Q relative   >> <<04776>>04758000
   << locations.                                            >> <<04776>>04760000
   <<*******************************************************>> <<04776>>04762000
                                                               <<04776>>04764000
   TOS := STACKDST;           << Target DST num., our stack.>> <<04776>>04766000
   TOS := Q'0'A+1;            << @VT'ADDR , targer offset.  >> <<04776>>04768000
   TOS := CBDST;              << CB DST, source DST number. >> <<04776>>04770000
   TOS := CBOFST;             << CB address, source offset. >> <<04776>>04774000
   IF CB'IN'STACK THEN                                         <<04776>>04776000
      TOS := TOS+PX'CBTAB;    << Add PX offset if in a stack>> <<04776>>04778000
   TOS := VTENTRY;            << Size of Vector Table Entry.>> <<04776>>04780000
                                                                        04782000
   <<*******************************************************>> <<04776>>04784000
   << Make sure that the needed data segment is in memory   >> <<04776>>04786000
   << before P-disableing.  Test bit one, word zero of the  >> <<04776>>04788000
   << DST entry.  If off, then the DST is not present.      >> <<04776>>04790000
   <<*******************************************************>> <<04776>>04792000
                                                                        04794000
AGAIN:                                                                  04796000
   DISABLE;                                                             04798000
                                                               <<04776>>04800000
   IF DST'(CBDST*DSTENTRY + 0).(0:1) = 1 THEN                  <<04776>>04802000
      BEGIN          << Not present. >>                                 04804000
      ENABLE;                                                           04806000
      QUEUEONSEGMENT(CBDST);                                   <<01701>>04808000
      GOTO AGAIN;                                                       04810000
      END;                                                              04812000
                                                                        04814000
   PSEUDODISABLE;    << Zot! >>                                         04816000
   ENABLE;                                                              04818000
   MOVE'DS'1;        << get 4 control words to VTADDR-CBL02 >>          04820000
   TOS := TOS-3;     << fix CBOFST >>                                   04822000
   ASMB(DXCH);                                                          04824000
   TOS := TOS-3;     << fix stack offset >>                             04826000
   TOS := 3;         << new word count >>                               04828000
      << Now TOS has the proper values for a MDS instruction            04830000
      to write back the three lock words.     >>                        04832000
                                                                        04834000
   IF NOT (9 <= VT'ADDR <= FSEGMAX) THEN FTROUBLE(59);                  04836000
   TOS := EASY'CASE;      << get CBLCONTROL and CBLQUEUE >>             04838000
   TOS := %100400+PIN;                                                  04840000
   TOS := 0;                                                            04842000
   ASMB(DCMP);            << Just us, and no one waiting? >>            04844000
   IF = AND FLAGS=0 THEN                                       <<01898>>04846000
      CBL' := 0           << Yes. That makes it easy. >>                04848000
   ELSE                                                                 04850000
      BEGIN                                                             04852000
      IF PIN <> CBL'PIN THEN FTROUBLE(50);                              04854000
      TOS := CBL'COUNT-1;  << Decrement count >>                        04856000
      IF = THEN                                                         04858000
         BEGIN              << Last reference by us. >>                 04860000
         DEL;               << Delete CBL'COUNT >>                      04862000
         IF CREATE'BREAK'MODE THEN                             <<04776>>04864000
            BEGIN               << Create Break queue. >>               04866000
            IF CBL'BREAK THEN GO L2;   << In Break now. >>              04868000
            CBL' := %040000;               << Break mode >>             04870000
            CBL'SAVEDQUEUE := CBL'QUEUE;   << save impeded queue >>     04872000
            CBL'QUEUE := 0;         << set impeded queue empty >>       04874000
            END                                                         04876000
         ELSE                                                           04878000
            BEGIN            << Un-impede next process.  >>             04880000
            IF FUNBREAK'MODE THEN                              <<04776>>04882000
               BEGIN             << Restore saved queue >>              04884000
               CBL'BREAK := 0;    << clear Break mode bit >>            04886000
               TOS := CBL'QUEUE;    << Break queue >>                   04888000
               TOS := CBL'SAVEDQUEUE;  << saved queue >>                04890000
               IF = THEN                                                04892000
                  DEL            << saved queue was empty >>            04894000
               ELSE IF S1 = 0 THEN                                      04896000
                  DELB           << Break queue was empty >>            04898000
               ELSE                                                     04900000
                  BEGIN           << Merge the queues >>                04902000
                  PCB(BS1*PCBSIZE+8).(8:8) := S0.(8:8);  << tail >>     04904000
                  BS1 := TOS.(0:8)      << tail PIN >>                  04906000
                  END;                                                  04908000
               CBL'QUEUE := TOS;      << new impeded queue >>           04910000
               CBL'SAVEDQUEUE := 0    << set saved queue empty >>       04912000
               END;          << restore saved queue >>                  04914000
L2:         TOS := CBL'QUEUE;      << impeded queue >>                  04916000
            IF = THEN                                                   04918000
               BEGIN             << Impeded queue was empty. >>         04920000
               TOS.(1:1) := CBL'BREAK;  << Break mode bit >>            04922000
               CBL' := TOS               << unlocked >>                 04924000
               END                                                      04926000
            ELSE                                                        04928000
               BEGIN            << impeded queue was occupied >>        04930000
               PIN := S0.(8:8);     << old head PIN runs next. >>       04932000
               TOS := PCBIQPTR;     << new head PIN >>                  04934000
               IF <> THEN                                               04936000
                  TOS.(8:8) := TOS    << insert new head >>             04938000
               ELSE                                                     04940000
                  DELB;                                                 04942000
               PCB(X).(8:8) := 0;     << clear impeded link >>          04944000
               CBL'QUEUE := TOS;      << new impeded queue >>           04946000
               CBL'PIN := PIN;        << PIN being given lock >>        04948000
               UNIMPEDE(PIN*PCBSIZE)  << start him up >>                04950000
               END             << non-empty queue >>                    04952000
            END                << unimpede the next process >>          04954000
         END                   << last reference by us >>               04956000
      ELSE      << not last reference >>                                04958000
         CBL'COUNT := TOS;   << update count >>                         04960000
      END;                                                              04962000
   MOVE'DS'5;          << post updated lock words in VT entry >>        04964000
   PSEUDOENABLE;                                                        04966000
   RETURN;     << total cutback >>                                      04968000
   END;     << procedure UNLOCK'CB >>                                   04970000
$PAGE  " LOCACB, UNLOCACB "                                             04972000
<<----------------------------------------------------------------------04974000
*                                                                      *04976000
*  Access Control Block (ACB) Maintenance Procedures                    04978000
*                                                                      *04980000
---------------------------------------------------------------------->>04982000
                                                                        04984000
$CONTROL SEGMENT = FILESYS1A  << LOC'ACB >>                             04986000
PROCEDURE LOC'ACB(DSTX,DQ,FILENUM,FLAGS,SIR,A);                <<04558>>04988000
                                                                        04990000
<<**********************************************************>> <<04558>>04992000
<<    Validates the file number, returns in DSTX the DST    >> <<04558>>04994000
<<  number which DB is set, and copies the AFT entry to     >> <<04558>>04996000
<<  ACB(-4) to ACB(-1).  If a conventional system file,     >> <<04558>>04998000
<<  builds an ACB at the user's specified Q-rel loc., con-  >> <<04558>>05000000
<<  sisting of the LACB and PACB data and an ACB extentsion >> <<04558>>05002000
<<  containing various usefull numbers.                     >> <<04558>>05004000
<<  The PACB is locked if the file is multi-access.         >> <<04558>>05006000
<<                                                          >> <<04558>>05008000
<<  If, when locking the PACV via LOCK'CB, we must be im-   >> <<04558>>05010000
<<  peded on the ACB, then we must first release any SIR    >> <<04558>>05012000
<<  that the process holds (FMAVT SIR at present) before    >> <<04558>>05014000
<<  being impeded.                                          >> <<04558>>05016000
<<                                                          >> <<04558>>05018000
<<                                                          >> <<04558>>05020000
<<   Input variables:                                       >> <<04558>>05022000
<<      DQ - Caller's Q-rel. ACB buffer location            >> <<04558>>05024000
<<      FILENUM - file number                               >> <<04558>>05026000
<<      FLAGS - flag word                                   >> <<04558>>05028000
<<          (0:1) - 1 if user in privileged mode            >> <<04558>>05030000
<<          (14:1) - create break queue [FBREAK]            >> <<04558>>05032000
<<      SIR, A - The FMAVT Sir and the return parameter     >> <<04558>>05034000
<<               from GETSIR.  If a process must impede upon>> <<04558>>05036000
<<               the ACB, then release the SIR before impe- >> <<04558>>05038000
<<               ding and then reaquire the SIR.            << <<04558>>05040000
<<                                                          >> <<04558>>05042000
<<   Output variable:                                       >> <<04558>>05044000
<<      DSTX - data seg of user's buffer                    >> <<04558>>05046000
<<   Output condition code:                                 >> <<04558>>05048000
<<      CCE - OK                                            >> <<04558>>05050000
<<      CCG - file is $NULL                                 >> <<04558>>05052000
<<      CCL - invalid file number                           >> <<04558>>05054000
<<                                                          >> <<04558>>05056000
<<   DB remains at the user's buffer.                       >> <<04558>>05058000
<<**********************************************************>> <<04558>>05060000
                                                                        05062000
VALUE DSTX,FILENUM,DQ,FLAGS,SIR,A;                             <<04558>>05064000
LOGICAL FLAGS;                                                          05066000
INTEGER DSTX,FILENUM,DQ,SIR,A;                                 <<04558>>05068000
OPTION PRIVILEGED,UNCALLABLE,VARIABLE;                         <<04558>>05070000
   BEGIN                                                                05072000
   EQUATE AFTENTRY'X'2 = AFTENTRY*2;                                    05074000
                                                               <<04558>>05076000
   LOGICAL PMAP = Q-4;                                         <<04558>>05078000
   << Conditional lock if SIR parameters are present.       >> <<04558>>05080000
   DEFINE SIR1       = PMAP.(14:2) = 3#,                       <<04558>>05082000
          COND'LOCK  = SIR1#;                                  <<04558>>05084000
                                                               <<04558>>05086000
                                                                        05088000
   INTEGER T1;      << Q+1 -- target for MDS >>                         05090000
                                                                        05092000
   DOUBLE STKADDR;   << Stack-DST-rel. addr of our Q+0 >>               05094000
      INTEGER STACKDST = STKADDR;                                       05096000
      INTEGER Q'0'A = STKADDR+1;                                        05098000
                                                                        05100000
   DOUBLE AFT01,AFT23;                                                  05102000
      INTEGER PACBV = AFT01+1;                                          05104000
      INTEGER LACBV = AFT23;                                            05106000
                                                                        05108000
   INTEGER PX'CBTAB;  << Stack-DST-relative addr of PXFILE CBTAB >>     05110000
                                                                        05112000
   INTEGER ARRAY ACB(*) =Q+0;                                  <<01790>>05114000
   LOGICAL ARRAY ACB'BUFX'(*) =ACB+31;                         <<01790>>05116000
   DEFINE ACB'BUFX =ACB'BUFX'(DQ)#;                            <<01790>>05118000
                                                                        05120000
   <<* * * Find Q-relative indices and check * * *>>                    05122000
                                                                        05124000
   DQ := DQ-DELTAQ;          << make @ACB relative to our Q >>          05126000
   STACKDST := PCB'STK;                                                 05128000
   DSTX := ABS(X := X-1).(1:10);  << DST where DB is >>                 05130000
   PUSH(DL,Q);                                                          05132000
   ASMB(XCH,SUB);            << DL-Q for Q-rel addressing >>            05134000
   ASMB(DUP,STBX);           << leave 1 for "Get AFTOFFSET" >>          05136000
   X := TOS-AQM1(X);         << (a-Q) <== (DL-Q) - (DL-a) >>            05138000
   T1 := AQPL1(X);      << Stack-DST-rel value of DB from PXGLOB(1) >>  05140000
   Q'0'A := -X;              << -(a-Q) >>                               05142000
 << Uses: PXGLOB size=8; PXFIXED size = PXFIXED(0). >>                  05144000
   TOS := AQPL8(X)+8;        << (c-b) + (b-a) -- @PXFILE >>             05146000
   PX'CBTAB := S0+PXFOVERHEAD;   << c-a+16 -- @PXFILE(16) >>            05148000
   X := X+TOS;                   << c-a + a-Q -- c-Q -- @PXFILE >>      05150000
   TOS := AFTENTRY;          << an equate for 4 today >>                05152000
   TOS := AQPL5(X);          << PXFILE(5) -- AFTSIZE in words >>        05154000
   X := FILENUM*AFTENTRY;                                               05156000
   IF NOT(TOS <= X <= TOS) THEN GO E1;  << Out of bounds. >>            05158000
   IF (X <= AFTENTRY'X'2) AND INTEGER(FLAGS) >= 0 THEN                  05160000
      BEGIN                    << non-priv ref to files 1, 2 >>         05162000
E1:   TOS := CCL;                                                       05164000
      GO GETOUT;                                                        05166000
      END;                                                              05168000
                                                                        05170000
   <<* * * Find AFT entry.  TOS is our Q-rel @PXFILE * * *>>            05172000
                                                                        05174000
   TOS := TOS-X-AFTENTRY;       << get AFTOFFSET >>                     05176000
           << TOS := (DL-Q) - AFTENTRY*FILENUM -- AFTENTRY >>           05178000
   X := S0;                  << keep a copy on TOS -- @AFT >>           05180000
   TOS := AQPL0(X);            << TOS := AFT(0) >>                      05182000
   ASMB(DUP);                  << keep a copy of AFT0 >>                05184000
   X := FTYPE'OF'TOS;          << TOS.(0:4)  >>                         05186000
   TOS := LEGAL'FTYPES;        << bit mask >>                           05188000
   ASMB(TBC 0,X);                                                       05190000
   IF = THEN GO E1;            << invalid type. >>                      05192000
   DEL;                        << delete bit mask >>                    05194000
   TOS.NULLFIELD := 0;         << uses TRBC on AFT0 >>                  05196000
   IF <> THEN                                                           05198000
      BEGIN                    << $NULL. >>                             05200000
      TOS := CCG;                                                       05202000
      GO GETOUT;                                                        05204000
      END;                                                              05206000
   ASMB(STBX);                 << saved value of @AFT >>                05208000
   TOS := AQPL1(X);            << get PACBV >>                          05210000
   IF = THEN GO E1;            << not FOPENed? >>                       05212000
   AFT01 := TOS;               << store double >>                       05214000
   TOS := AQPL2(X);            << get LACBV >>                          05216000
   TOS := AQPL3(X);            << get IOQX >>                           05218000
   AFT23 := TOS;               << store double >>                       05220000
   IF <> THEN CARRYCODE := 1;  << test IOQX for pend Nowait I/O >>      05222000
                                                                        05224000
   X := TOS := DQ;                                                      05226000
   XACBOFST := TOS+Q'0'A;    << save DST-rel @ACB in ACBX >>            05228000
   TOS := AFT23;        << Copy AFT entry to ACB-4. >>                  05230000
   AQM1(X) := TOS;      << IOQX >>                                      05232000
   AQM2(X) := TOS;      << LACBV >>                                     05234000
   TOS := AFT01;                                                        05236000
   AQM3(X) := TOS;      << PACBV >>                                     05238000
   AQM4(X) := S0;       << AFTE.  Now, wasn't that fun? >>              05240000
   TOS:=FTYPE'OF'TOS;                                          <<HM.00>>05242000
   IF S0<>0 AND S0<>MSG'TYPE THEN GO OK; <<Not FS, msg; done>> <<HM.00>>05244000
   DEL;                                                        <<HM.00>>05246000
   XPXCBTOFST := PX'CBTAB;                                              05248000
   XDBOFST := T1;                                                       05250000
   XLACBDST := LACBV.DSTN;                                              05252000
   IF <> THEN                                                           05254000
      BEGIN            << LACB exists. Must lock PACB >>                05256000
      IF COND'LOCK THEN FLAGS.(1:1) := 1; << Turn on condi- >> <<04558>>05258000
                                          << ional lock bit >> <<04558>>05260000
      TOS := FLAGS;         << for LOCK'CB flag >>                      05262000
      TOS.(0:1) := 0;       << clear PM bit >>                          05264000
      TOS := STKADDR;       << DST & address of our Q+0 >>              05266000
      TOS := TOS+1;          << @T1 >>                                  05268000
      TOS := XLACBDST;                                                  05270000
      TOS := LACBV VTA;                                                 05272000
      IF XLACBDST = STACKDST THEN                                       05274000
         TOS := TOS+PX'CBTAB;       << DST-rel @VTe >>                  05276000
      TOS := 1;                                                         05278000
      MOVE'DS'4;        << get CBT-rel LACB addr from VT >>             05280000
      TOS := XACBOFST;     << DST-rel @ACB >>                           05282000
      TOS := XLACBDST;                                                  05284000
      TOS := T1;           << address rel. to CBTAB >>                  05286000
      IF XLACBDST = STACKDST THEN                                       05288000
         TOS := TOS+PX'CBTAB;                                           05290000
      XLACBOFST := S0;   << save DST-rel @LACB for UNLOC'ACB >>         05292000
      TOS := SIZELACB;                                                  05294000
      MOVE'DS'4;         << leave STK'DST >>                            05296000
                                                                        05298000
      TOS := DQ+SIZELACB;    << offset into ACB >>                      05300000
      TOS := XPACBDST := PACBV.DSTN;                                    05302000
      TOS := XPACBVTA := PACBV VTA;                                     05304000
      LOCK'CB(*,*,*,*,*);    << Really lock PACB >>                     05306000
                                                               <<04558>>05308000
      <<****************************************************>> <<04558>>05310000
      << If CARRY returned, we must release SIR before      >> <<04558>>05312000
      << impeding on the ACB so as not to lock system       >> <<04558>>05314000
      << resources (FMAVT SIR).                             >> <<04558>>05316000
      <<****************************************************>> <<04558>>05318000
                                                               <<04558>>05320000
      IF CARRY THEN                                            <<04558>>05322000
         BEGIN                                                 <<04558>>05324000
           IF SIR1 AND A <> -1                                 <<04558>>05326000
              THEN RELSIR(SIR,A);    << Release SIR         >> <<04558>>05328000
           IMPEDE(0);                << Wait for CB lock.   >> <<04558>>05330000
           IF SIR1 AND A <> -1                                 <<04558>>05332000
              THEN A := GETSIR(SIR); << Re-aquire SIR       >> <<04558>>05334000
         END;                                                  <<04558>>05336000
                                                               <<04558>>05338000
      XPACBOFST := S0;       << save DST-rel @PACB for UNLOC'ACB >>     05340000
      TOS := TOS+SIZELACB;   << adjust start of PACB data >>            05342000
      TOS := SIZEMRPACB;                                                05344000
      MOVE'DS'6;             << copy PACB to ACB. Pop FLAGS >>          05346000
      IF ACB'PRIV AND INTEGER(FLAGS) >= 0 THEN                 <<01790>>05348000
         BEGIN     << non-priv access to priv file. >>         <<01790>>05350000
         UNLOCK'CB(FLAGS,XPACBDST,XPACBVTA);                   <<01790>>05352000
         GO E1                                                 <<01790>>05354000
         END;                                                  <<01790>>05356000
      END                                                               05358000
   ELSE                                                                 05360000
      BEGIN        << no need to lock PACB >>                           05362000
      XLACBOFST := 0;                                                   05364000
      TOS := STKADDR;     << DST and addr of our Q+0 >>                 05366000
      TOS := TOS+1;        << @T1 >>                                    05368000
      TOS := XPACBDST := PACBV.DSTN;                                    05370000
      TOS := XPACBVTA := PACBV VTA;                                     05372000
      IF XPACBDST = STACKDST THEN                                       05374000
         TOS := TOS+PX'CBTAB;    << DST-rel @VTe >>                     05376000
      TOS := 1;                                                         05378000
      MOVE'DS'4;     << get CBT-rel. PACB addr. to T1 >>                05380000
      TOS := XACBOFST;        << DST-rel @ACB >>                        05382000
      TOS := XPACBDST;                                                  05384000
      TOS := T1;                                                        05386000
      IF XPACBDST = STACKDST THEN                                       05388000
         TOS := TOS+PX'CBTAB;                                           05390000
      XPACBOFST := S0;       << save DST-rel locn. of PACB >>           05392000
      TOS := SIZEACB;                                                   05394000
      MOVE'DS'5;         << copy PACB to ACB >>                         05396000
      IF ACB'PRIV AND INTEGER(FLAGS) >= 0 THEN                 <<01790>>05398000
         GO E1;    << non-priv access to priv file. >>         <<01790>>05400000
      END;                                                              05402000
OK:                                                                     05404000
   TOS := CCE;        << OK >>                                          05406000
                                                                        05408000
GETOUT:                                                                 05410000
   CONDCODE := TOS;        << return error code >>                      05412000
   RETURN 6;                                                   <<04558>>05414000
   END;       << of LOC'ACB >>                                          05416000
$CONTROL SEGMENT = FILESYS1A  << UNLOC'ACB >>                           05418000
                                                                        05420000
PROCEDURE UNLOC'ACB(DQ,FLAGS);                                          05422000
   << This procedure releases the ACB by storing the contents back      05424000
     into the PACB, and into the LACB (if it exists).  The PACB is      05426000
     unlocked (if locked), and the first process waiting for it         05428000
     (if any) is unimpeded.  DB remains at the user's buffer.  This     05430000
     procedure must only be called if LOC'ACB reported a conventional   05432000
     FS file, since the addresses of the control block locks            05434000
     are taken from the ACBX.                                           05436000
     FLAGS is used only if the LACB exists, since $STDIN is             05438000
     always multi-access.                                               05440000
                                                                        05442000
     Input variables:                                                   05444000
         DQ - Caller's Q-rel addr of his ACB                            05446000
         FLAGS - flag word                                              05448000
            (13:1) - destroy Break queue [FUNBREAK]                     05450000
            (14:1) - create Break queue [IOMOVE (terminal, NOBUF)]      05452000
>>                                                                      05454000
VALUE DQ,FLAGS;                                                         05456000
INTEGER DQ;                                                             05458000
LOGICAL FLAGS;                                                          05460000
OPTION PRIVILEGED,UNCALLABLE;                                           05462000
                                                                        05464000
   BEGIN                                                                05466000
      INTEGER STACKDST;                                                 05468000
                                                                        05470000
   STACKDST := PCB'STK;                                                 05472000
   X := DQ := DQ-DELTAQ;   << make relative to our Q >>                 05474000
   TOS := FLAGS;                                                        05476000
   TOS := XLACBDST;                                                     05478000
   IF <> THEN                                                           05480000
      BEGIN         << LACB exists >>                                   05482000
      TOS := XLACBOFST+SIZENOWR;   << dest. >>                          05484000
      TOS := STACKDST;                                                  05486000
      TOS := XACBOFST+SIZENOWR;                                         05488000
      TOS := SIZELACBWR;                                                05490000
      MOVE'DS'5;       << Update LACB. Leave UNLOCK'CB flag >>          05492000
                                                                        05494000
      TOS := XPACBDST;      << dest. >>                                 05496000
      TOS := XPACBOFST+SIZENOWR;                                        05498000
      TOS := STACKDST;                                                  05500000
      TOS := XACBOFST+SIZENOWR;                                         05502000
      TOS := SIZEPACBWR;                                                05504000
      MOVE'DS'4;        << update PACB. Leave PACBDST, FLAGS >>         05506000
      UNLOCK'CB(*,*,XPACBVTA);     << release PACB >>                   05508000
      END                                                               05510000
   ELSE                                                                 05512000
      BEGIN         << No LACB; just update PACB. >>                    05514000
      TOS := TOS+XPACBDST;    << flush extra 0 >>                       05516000
      TOS := XPACBOFST+SIZENOWR;                                        05518000
      TOS := STACKDST;    << source is ACB >>                           05520000
      TOS := XACBOFST+SIZENOWR;                                         05522000
      TOS := SIZEPACBWR;                                                05524000
      MOVE'DS'6;        << update PACB; flush FLAGS >>                  05526000
      END;                                                              05528000
   END;      << of UNLOC'ACB >>                                         05530000
$PAGE " POST'ACB'ERROR "                                       <<04558>>05532000
$CONTROL SEGMENT = FILESYS1A  <<POST'ACB'ERROR>>               <<02702>>05534000
PROCEDURE POST'ACB'ERROR(FILENUM,THEIRSTATUS,ERROR);           <<02702>>05536000
  VALUE FILENUM,THEIRSTATUS,ERROR;                             <<02702>>05538000
  INTEGER FILENUM,ERROR;                                       <<02702>>05540000
  LOGICAL THEIRSTATUS;                                         <<02702>>05542000
  OPTION PRIVILEGED,UNCALLABLE;                                <<02702>>05544000
<< this procedure calls LOC'ACB                              >><<02702>>05546000
<< to put an error into the acb.                             >><<02702>>05548000
BEGIN                                                          <<02702>>05550000
                                                               <<02702>>05552000
  EQUATE SIZEXACB = %70;                                       <<02702>>05554000
  EQUATE ACBMQ    =   5;                                       <<02702>>05556000
                                                               <<02702>>05558000
  <<the following loc'acb params must be last and in order>>   <<02702>>05560000
  INTEGER AFTE;                                                <<02702>>05562000
  INTEGER PACBV;                                               <<02702>>05564000
  INTEGER LACBV;                                               <<02702>>05566000
  INTEGER IOQX;                                                <<02702>>05568000
  INTEGER ARRAY ACB(0:SIZEXACB-1) = Q; << q + acbmq >>         <<02702>>05570000
  DOUBLE ARRAY ACBDBL(*)=ACB;                                  <<02702>>05572000
  << build'acb >>                                              <<02702>>05574000
  INTEGER ACB'ERROR = ACB + 14;                                <<02702>>05576000
  LOGICAL DSTX;                                                <<02702>>05578000
  <<end of loc'acb params >>                                   <<02702>>05580000
  LOC'ACB(*,ACBMQ,FILENUM,THEIRSTATUS);                        <<02702>>05582000
  IF <> THEN FTROUBLE(455);                                    <<02702>>05584000
  ACB'ERROR:=ERROR;                                            <<02702>>05586000
  UNLOC'ACB(ACBMQ,0);                                          <<02702>>05588000
END;                                                           <<02702>>05590000
$PAGE " FBNDVIOL "                                             <<04558>>05592000
$CONTROL SEGMENT = FILESYS1A  << FBNDVIOL >>                            05594000
LOGICAL PROCEDURE FBNDVIOL(TARGET,WC,UBND);                             05596000
COMMENT                                                                 05598000
     This procedure bounds-checks the user's buffer.  It is used        05600000
when the buffer is a word address but the size can be either            05602000
words(+) or bytes (-).  If the buffer can be a byte address,            05604000
use FBNDCHK instead.                                                    05606000
                                                                        05608000
     Input variables:                                                   05610000
         TARGET - user's buffer address (words)                         05612000
         WC   - user's specified word or byte count                     05614000
         UBND - upper word bound, for bounds check                      05616000
                relative to caller's Q register                <<03059>>05618000
                (a small negative number)                      <<03059>>05620000
                                                                        05622000
     Output variables: FBNDVIOL - True if out of bounds.                05624000
                                                                        05626000
     DB is assumed to be set to the data segment                        05628000
     containing the user's buffer.  ;                                   05630000
                                                                        05632000
VALUE TARGET,UBND,WC;                                                   05634000
INTEGER TARGET,UBND,WC;                                                 05636000
OPTION PRIVILEGED,UNCALLABLE;                                           05638000
                                                                        05640000
   BEGIN                                                                05642000
   INTEGER DSTX;                                                        05644000
   INTEGER DELTAQ=Q-0;                                         <<03059>>05646000
                                                                        05648000
   IF WC < 0 THEN                                                       05650000
      WC := (1-WC)&LSR(1);    << make pos. words >>                     05652000
   DSTX := PCB'XDS;         << User's buffer DST >>                     05654000
   IF <> THEN                                                           05656000
      BEGIN     << DB at extra data segment. >>                         05658000
      TOS := 0;  << lower bound >>                                      05660000
      TOS := DST'(DSTX&LSL(2)).(3:13)&LSL(2)-WC;   <<UB>>               05662000
      END                                                               05664000
   ELSE                                                                 05666000
      BEGIN        << DB at stack. >>                                   05668000
      IF UBND >= 0 THEN                                        <<03059>>05670000
        BEGIN                                                  <<03059>>05672000
        <<Some pre-ICF/55 code has called with a DB relative>> <<03059>>05674000
        <<rather than Q relative address.  Catch it.>>         <<03059>>05676000
        FBNDVIOL := TRUE;                                      <<03059>>05678000
        RETURN;                                                <<03059>>05680000
        END;                                                   <<03059>>05682000
      PUSH(DL);     << lower word bound >>                              05684000
      TOS := @DELTAQ-DELTAQ+UBND-WC+1; << upper word bound>>   <<03059>>05686000
      END;                                                              05688000
   X := TARGET;                                                         05690000
   IF NOT(TOS <= X <= TOS) THEN                                         05692000
      FBNDVIOL := TRUE;    << Bounds violation. Boo! >>                 05694000
                                                                        05696000
   END;      << procedure FBNDVIOL >>                                   05698000
$PAGE   " PUT'ACB'INFO "                                       <<04700>>05700000
$CONTROL SEGMENT=FILESYS1A                                     <<04700>>05702000
PROCEDURE PUT'ACB'INFO(FILE'NUM,ITEM'NUM,ITEM);                <<04700>>05704000
VALUE FILE'NUM,ITEM'NUM,ITEM;                                  <<04700>>05706000
INTEGER FILE'NUM,ITEM'NUM,ITEM;                                <<04700>>05708000
OPTION UNCALLABLE,PRIVILEGED;                                  <<04700>>05710000
                                                               <<04700>>05712000
<<**********************************************************>> <<04700>>05714000
<< This procedure is used by our friends at DS to place cer->> <<04700>>05716000
<< tain items in the ACB.                                   >> <<04700>>05718000
<<                                                          >> <<04700>>05720000
<< Input variables:                                         >> <<04700>>05722000
<<    FILE'NUM - File number for which to use.              >> <<04700>>05724000
<<    ITEM'NUM - Number specifying the particular ACB item  >> <<04700>>05726000
<<               in which to replace.  The following values >> <<04700>>05728000
<<               are legal:                                 >> <<04700>>05730000
<<                                                          >> <<04700>>05732000
<<               1 - ACB'ERROR                              >> <<04700>>05734000
<<               2 - ACB'DADDR                              >> <<04700>>05736000
<<                                                          >> <<04700>>05738000
<<    ITEM     - The item to place in the ACB location.     >> <<04700>>05740000
<<                                                          >> <<04700>>05742000
<< Condition Codes:                                         >> <<04700>>05744000
<<    CCE - Everything is A-OK.                             >> <<04700>>05746000
<<    CCL - Invalid file number or invalid item number.     >> <<04700>>05748000
<<    CCG - File is $NULL file.                             >> <<04700>>05750000
<< DB can be set to anywhere upon entrance.                 >> <<04700>>05752000
<<**********************************************************>> <<04700>>05754000
                                                               <<04700>>05756000
BEGIN                                                          <<04700>>05758000
                                                               <<04700>>05760000
<< ACB declarations must be in order!                       >> <<04700>>05762000
INTEGER                                                        <<04700>>05764000
   ACBMQ,    << Q-relative offset to our ACB.               >> <<04700>>05766000
   AFTE,     << Word 0 of the AFT, type of file, $NULL bit. >> <<04700>>05768000
   PACBV,    << Physical Access Control Block Vector.       >> <<04700>>05770000
   LACBV,    << Logical    "        "     "       "         >> <<04700>>05772000
   IOQX;     << I/O Queue Index, used for No-Wait I/O files.>> <<04700>>05774000
INTEGER ARRAY ACB(0:SIZEXACB - 1) = Q;                         <<04700>>05776000
INTEGER                                                        <<04700>>05778000
   DSTX;        << Users current DB DST.                    >> <<04700>>05780000
BUILD'ACB;      << Define, declares ACB variables.          >> <<04700>>05782000
                                                               <<04700>>05784000
<< Check for legal item number.                             >> <<04700>>05786000
                                                               <<04700>>05788000
CONDCODE := CCE;            << Assume successful completion.>> <<04700>>05790000
IF ITEM'NUM < 1 OR ITEM'NUM > 2 THEN                           <<04700>>05792000
   CONDCODE := CCL                                             <<04700>>05794000
ELSE                                                           <<04700>>05796000
   BEGIN                                                       <<04700>>05798000
   GET'ACB'Q'LOC;        << Obtain Q-relative loc. of ACB.  >> <<04700>>05800000
   LOC'ACB(0,ACBMQ,FILE'NUM,UMODE);                            <<04700>>05802000
   DSTX := TOS;          << LOC'ACB returns DSTX on TOS.    >> <<04700>>05804000
   IF < THEN                                                   <<04700>>05806000
      CONDCODE := CCL    << Invalid file number.            >> <<04700>>05808000
   ELSE IF > THEN                                              <<04700>>05810000
      CONDCODE := CCG    << $NULL.                          >> <<04700>>05812000
   ELSE IF NOT FSTYPE AND NOT MSGTYPE THEN                     <<04766>>05814000
      CONDCODE := CCG    << Not a legal file type.          >> <<04766>>05816000
   ELSE                                                        <<04700>>05818000
      BEGIN              << OK, place item in proper loc.   >> <<04700>>05820000
      ITEM'NUM := ITEM'NUM - 1;  << CASE starts at 0.       >> <<04700>>05822000
      CASE ITEM'NUM OF                                         <<04700>>05824000
           BEGIN                                               <<04700>>05826000
                                                               <<04700>>05828000
           <<  1  >>                                           <<04700>>05830000
           ACB'ERROR := ITEM;                                  <<04700>>05832000
           <<  1  >>                                           <<04700>>05834000
                                                               <<04700>>05836000
           <<  2  >>                                           <<04700>>05838000
           ACB'DADDR := ITEM;                                  <<04700>>05840000
           <<  2  >>                                           <<04700>>05842000
                                                               <<04700>>05844000
           END;                                                <<04700>>05846000
       UNLOC'ACB(ACBMQ,0);                                     <<04700>>05848000
       END;                                                    <<04700>>05850000
   END;                                                        <<04700>>05852000
                                                               <<04700>>05854000
END;   << PROCEDURE PUT'ACB'INFO                            >> <<04700>>05856000
$PAGE " GETFCB'INFO "                                          <<04558>>05858000
$ CONTROL SEGMENT = FILESYS1A  << GETFCB'INFO >>                        05860000
DOUBLE PROCEDURE GETFCB'INFO(FCBV, ITEM);                               05862000
VALUE FCBV, ITEM;                                                       05864000
INTEGER FCBV, ITEM;                                                     05866000
OPTION PRIVILEGED,UNCALLABLE;                                           05868000
                                                               <<04558>>05870000
<<**********************************************************>> <<04558>>05872000
<< GETFCB'INFO returns as its value two words from an FCB   >> <<04558>>05874000
<< from the desired FCB word offset.                        >> <<04558>>05876000
<<                                                          >> <<04558>>05878000
<< Input Variables:                                         >> <<04558>>05880000
<<    FCBV - The File Control Block Vector.                 >> <<04558>>05882000
<<    ITEM - The word offset into the FCB in which to start >> <<04558>>05884000
<<           the two word transfer.                         >> <<04558>>05886000
<<                                                          >> <<04558>>05888000
<< Output Variables:                                        >> <<04558>>05890000
<<    GETFCB'INFO - The two words retieved from the FCB     >> <<04558>>05892000
<<                  starting at ITEM.                       >> <<04558>>05894000
<<                                                          >> <<04558>>05896000
<< Copy the 2 words th Q-7, the return parameter location,  >> <<04558>>05898000
<< using the parameters returned from LOCK'CB.  The FCB is  >> <<04558>>05900000
<< locked via the "quick lock" mode.  If FLAG is returned   >> <<04558>>05902000
<< true, then we must explicitly unlock the FCB, otherwise  >> <<04558>>05904000
<< we simply P-Disable ourselves and return.                >> <<04558>>05906000
<<**********************************************************>> <<04558>>05908000
                                                               <<04558>>05910000
                                                                        05912000
   BEGIN                                                                05914000
   LOCK'CB(8,0,-7,FCBV.DSTN,FCBV VTA);  << quick lock >>                05916000
   TOS := TOS+ITEM;       << source offset into FCB >>                  05918000
   TOS := 2;                                                            05920000
   MOVE'DS'5;    << move data to GETFCB'INFO return >>                  05922000
   IF LOGICAL(TOS) THEN UNLOCK'CB(0,FCBV.DSTN,                          05924000
      FCBV VTA) ELSE PSEUDOENABLE;                                      05926000
   END;      << procedure GETFCB'INFO >>                                05928000
$PAGE " PUTFCB'INFO "                                          <<04562>>05930000
$CONTROL SEGMENT=FILESYS1A                                     <<04562>>05932000
                                                               <<04562>>05934000
PROCEDURE PUTFCB'INFO(FCBV,OFFSET,ITEM);                       <<04562>>05936000
VALUE FCBV,OFFSET,ITEM;                                        <<04562>>05938000
INTEGER FCBV,OFFSET;                                           <<04562>>05940000
DOUBLE ITEM;                                                   <<04562>>05942000
OPTION PRIVILEGED,UNCALLABLE;                                  <<04562>>05944000
                                                               <<04562>>05946000
<<**********************************************************>> <<04562>>05948000
<< This procedure transfers a double word into the FCB at a >> <<04562>>05950000
<< desired location.  It is used by STORE/RESTORE and IOMOVE>> <<04562>>05952000
<< to update the EOF in the FCB.                            >> <<04562>>05954000
<<                                                          >> <<04562>>05956000
<< Input variables:                                         >> <<04562>>05958000
<<    FCBV   - FCB vector.                                  >> <<04562>>05960000
<<    OFFSET - The word offset into the FCB in which to     >> <<04562>>05962000
<<             start the transfer.                          >> <<04562>>05964000
<<    ITEM   - The double word item to transfer.            >> <<04562>>05966000
<<                                                          >> <<04562>>05968000
<< Transfer the ITEM from Q-5 to the FCB offset.            >> <<04562>>05970000
<<**********************************************************>> <<04562>>05972000
                                                               <<04562>>05974000
BEGIN                                                          <<04562>>05976000
                                                               <<04562>>05978000
DOUBLE                                                         <<04562>>05980000
   SOURCE'WORDS,           << Bank and address of ITEM.     >> <<04562>>05982000
   TARGET'WORDS;           << Bank and address of FCB words.>> <<04562>>05984000
INTEGER                                                        <<04562>>05986000
   TARGET'ADDR=TARGET'WORDS + 1;                               <<04562>>05988000
LOGICAL                                                        <<04562>>05990000
   LOCKED;                  << True if quick lock failed.   >> <<04562>>05992000
EQUATE                                                         <<04562>>05994000
   QUICK'LOCK      = %(2)1000,                                 <<04562>>05996000
   Q'REL'LOC'ITEM  = -5;                                       <<04562>>05998000
                                                               <<04562>>06000000
LOCK'CB(QUICK'LOCK,0,Q'REL'LOC'ITEM,FCBV.DSTN,FCBV VTA);       <<04562>>06002000
TARGET'WORDS := TOS;                                           <<04562>>06004000
SOURCE'WORDS := TOS;                                           <<04562>>06006000
LOCKED := TOS;                                                 <<04562>>06008000
                                                               <<04562>>06010000
<< Place the target and source addresses up on TOS.         >> <<04562>>06012000
                                                               <<04562>>06014000
TARGET'ADDR := TARGET'ADDR + OFFSET;                           <<04562>>06016000
TOS := TARGET'WORDS;                                           <<04562>>06018000
TOS := SOURCE'WORDS;                                           <<04562>>06020000
TOS := 2;                                                      <<04562>>06022000
MOVE'DS'5;                 << Off they go!                  >> <<04562>>06024000
                                                               <<04562>>06026000
IF LOCKED                  << Did we get the quick lock?    >> <<04562>>06028000
   THEN UNLOCK'CB(0,FCBV.DSTN,FCBV VTA)                        <<04562>>06030000
   ELSE PSEUDOENABLE;                                          <<04562>>06032000
                                                               <<04562>>06034000
END;                                                           <<04562>>06036000
$PAGE " FBNDCHK "                                              <<04558>>06038000
$ CONTROL SEGMENT = FILESYS3   << FBNDCHK >>                            06040000
LOGICAL PROCEDURE FBNDCHK (PARM,SIZE,UBND);                             06042000
   << Checks whether DB is at the stack, and if so, that the            06044000
  specified area (PARM to PARM+SIZE-1) is within bounds.                06046000
                                                                        06048000
     Input variables:                                                   06050000
         PARM - initial stack address (word or byte address)            06052000
         SIZE - number of stack words                                   06054000
         UBND - upper stack bound (word address)                        06056000
                                                                        06058000
     Output variables:                                                  06060000
         FBNDCHK - error indication                                     06062000
            1 - DB not at stack. Callers generally consider this OK.    06064000
            FALSE - out of bounds                                       06066000
            TRUE - OK                                                   06068000
                                                                        06070000
     For word address, check size must be positive; for byte            06072000
     address, check size must be negative.   >>                         06074000
VALUE PARM,SIZE,UBND;                                                   06076000
INTEGER PARM,SIZE,UBND;                                                 06078000
OPTION PRIVILEGED,UNCALLABLE;                                           06080000
   BEGIN                                                                06082000
   INTEGER DELTAQ=Q-0;                                         <<03059>>06084000
   CHECKDB;      << Where's DB?>>                                       06086000
   IF <> THEN                                                           06088000
      BEGIN    << Not at the stack. >>                                  06090000
      FBNDCHK := 1;                                                     06092000
      RETURN;                                                           06094000
      END;                                                              06096000
   IF SIZE < 0 THEN                                                     06098000
      BEGIN     << Convert for byte addressing. >>                      06100000
      PARM := PARM&LSR(1);                                              06102000
      PUSH(S);                                                          06104000
      IF TOS < PARM THEN PARM.(0:1) := 1;                               06106000
      SIZE := (1-SIZE)&LSR(1);                                          06108000
      END;                                                              06110000
   IF UBND >= 0 THEN                                           <<03059>>06112000
     <<Some pre-ICF/55 code has called with a DB relative,>>   <<03059>>06114000
     <<rather than Q relative, address.  Catch it.>>           <<03059>>06116000
     BEGIN                                                     <<03059>>06118000
     FBNDCHK := TRUE;                                          <<03059>>06120000
     RETURN;                                                   <<03059>>06122000
     END;                                                      <<03059>>06124000
   PUSH(DL);     << lower bound >>                                      06126000
   TOS := @DELTAQ-DELTAQ+UBND-SIZE+1;                          <<03059>>06128000
   X := PARM;     << initial address >>                                 06130000
   IF NOT (TOS <= X <= TOS) THEN RETURN;  << if out of bnds >>          06132000
   FBNDCHK := TRUE                                                      06134000
   END;     << procedure FBNDCHK >>                                     06136000
$PAGE  " FCONV'BLK "                                                    06138000
$CONTROL SEGMENT = FILESYS1A  << FCONV'BLK >>                           06140000
                                                                        06142000
PROCEDURE FCONV'BLK(BLOCK,LDEV,CODE,STX,FCEOF,EXTBASE,EXTSIZE);<<04653>>06144000
   << This procedure determines the disk address of the specified       06146000
   block.  If it lies in a non-existent extent, the extent is created.  06148000
   The number of words remaining within the extent gives the            06150000
   maximum allowable transfer size.                                     06152000
                                                                        06154000
   The procedure also releases spoofle extents after they have          06156000
   been read for the last time.                                         06158000
                                                                        06160000
     Input variables:                                                   06162000
         BLOCK - block number                                           06164000
         LDEV - caller's Q-rel ACB location                             06166000
         CODE - I/O op code:                                            06168000
            0 - Read                                                    06170000
            1 - Write                                                   06172000
         STX  - ignored                                                 06174000
         FCEOF - ignored                                                06176000
         EXTBASE - ignored                                              06178000
         EXTSIZE - ignored                                              06180000
                                                                        06182000
     Output variables:                                                  06184000
         BLOCK - sector address of specified block                      06186000
         LDEV - logical device nr. of extent containing block           06188000
         CODE - record location code                                    06190000
           -1 - Reading from an un-allocated extent            <<ALEXT  06192000
            0 - OK                                                      06194000
            1 - Beyond EOF                                              06196000
            2 - Beyond file limit                                       06198000
            N - FS error number                                         06200000
         STX  - sectors available in extent                             06202000
         FCEOF - EOF record nr.                                         06204000
         EXTBASE - double sector address of current extent              06206000
         EXTSIZE - size (in sectors) of current extent                  06208000
                                                                        06210000
     The output variables are returned by a partial cutback of          06212000
     the stack.  DB can be anywhere, although normally it will          06214000
     be at the user's buffer.                                           06216000
>>                                                                      06218000
<< NOTE:                                                    >> <<04160>>06220000
<< We will only acquire the FISIR if the file was not opened>> <<04160>>06222000
<< EXC. The sir is used to "lock" the FLAB while updating   >> <<04160>>06224000
<< the extent map. Since EXC is used, we will be the only   >> <<04160>>06226000
<< process accessing the FLAB. This is especially important >> <<04160>>06228000
<< because of past hangs dealing with the FISIR and System  >> <<04160>>06230000
<< Logging.                                                 >> <<04160>>06232000
                                                               <<04160>>06234000
   VALUE BLOCK,LDEV,CODE,STX,FCEOF,EXTBASE,EXTSIZE;            <<04653>>06236000
   INTEGER LDEV,CODE;                                                   06238000
   LOGICAL STX,EXTSIZE;                                        <<04653>>06240000
   DOUBLE BLOCK,FCEOF,EXTBASE;                                 <<04653>>06242000
   OPTION PRIVILEGED,UNCALLABLE;                                        06244000
BEGIN                                                                   06246000
                                                                        06248000
INTEGER FCBMQ;                                                 <<04578>>06252000
   << ACB variables >>                                                  06254000
                                                                        06256000
DEFINE                                                                  06258000
   ACB'FNUM    =AQ0(ACBQ+1)#,                                           06260000
   ACB'FOPTIONS=LQ0(ACBQ+6)#,                                  <<04159>>06262000
   ACB'AOPTIONS=LQ0(ACBQ+7)#,                                  <<04160>>06264000
   ACB'EXCL    =(ACB'AOPTIONS.(8:2) = 1)#,   << EXC Access >>  <<04160>>06266000
   ACB'RSIZE   =AQ0(ACBQ+8)#,    << Record size >>             <<04159>>06268000
   ACB'BLKLO   =AQ0(ACBQ+19)#,   << lo half ACBBLK >>                   06270000
   ACB'FCB     =AQ0(ACBQ+26)#,                                          06272000
   ACB'STATW   =LQ0(ACBQ+29)#,                                          06274000
   ACB'AMLD    =AQ0(ACBQ+38)#,                                          06278000
   ACB'SPFL    =LQ0(ACBQ+39)#,                                          06280000
   ACB'SPXDDX  =AQ0(ACBQ+43)#;                                 <<04450>>06282000
                                                               <<04159>>06284000
   INTEGER ACBQ;         << our Q-rel addr of caller's ACB >>           06288000
   LOGICAL SPOOLF;        << -1 if spooler, +1 if user >>               06290000
   INTEGER POINTER XDDEP;  << spoofle directory entry pointer >>        06292000
                                                                        06294000
   << FCB variables >>                                                  06296000
                                                                        06298000
   DOUBLE EMAPADDR;     << FCB DST & e-map offset >>                    06300000
                                                                        06302000
   << Record and block parameters >>                                    06304000
                                                                        06306000
   LOGICAL NEWEXTSIZE;   << sectors >>                                  06308000
   DOUBLE BLKFACT;                                                      06310000
   DOUBLE NEWEXTD;       << E-map data for new block >>                 06312000
      INTEGER NEWEXTX = NEWEXTD;   << E-table index >>                  06314000
      LOGICAL NEWEXTO = NEWEXTD+1; << offset, sectors >>                06316000
                                                                        06318000
   DOUBLE OLDEOFBLK;     << first block beyond present EOF >>           06320000
   DOUBLE OLDEOFD;       << E-map data for old EOF >>                   06322000
      INTEGER OLDEOFX = OLDEOFD;   << E-table index >>                  06324000
      LOGICAL OLDEOFO = OLDEOFD+1; << offset, sectors >>                06326000
                                                                        06328000
   DOUBLE DJ1J2;                                                        06330000
      INTEGER J1 = DJ1J2;                                               06332000
                                                                        06334000
                                                                        06336000
   << Output spoofle squeeze >>                                         06338000
                                                                        06340000
   LOGICAL SQEEZE;  << TRUE if spoofle is being squeezed >>             06342000
   INTEGER Z;       << index of first non-purged extent >>              06344000
   INTEGER DX;      << data seg nr. >>                                  06346000
                                                                        06348000
   << File label access >>                                              06350000
                                                                        06352000
   INTEGER POINTER FLAB;  << file label pointer >>                      06354000
   DOUBLE POINTER FLABDBL = FLAB;                                       06356000
                                                                        06358000
                                                               <<04564>>06360000
                                                                        06362000
   INTEGER A;             << File SIR >>                                06364000
                                                                        06366000
EQUATE                                                         <<04567>>06370000
       WRITE      =   1,     << ATTACHIO function code >>      <<04567>>06372000
       UNALLOC'EXT = -1;     << Reading from unalloc. ext   >> <<04567>>06374000
                                                               <<04159>>06378000
                                                               <<04159>>06380000
INTEGER ARRAY FCB'(0:SIZEBFCB-1) = Q;                          <<04159>>06382000
LOGICAL FCB'FOPTIONS    = FCB'+2;                              <<04159>>06384000
INTEGER FCB'DEVICE      = FCB'+3;                              <<04159>>06386000
INTEGER FCB'PVINFO      = FCB'+9;                              <<04159>>06388000
DOUBLE FCB'FLIM         = FCB'+10;                             <<04159>>06390000
DOUBLE FCB'EOF          = FCB'+14;                             <<04159>>06392000
LOGICAL FCB'EXTSIZE     = FCB'+17;                             <<04159>>06394000
LOGICAL FCB'BFSPB       = FCB'+18;                             <<04159>>06396000
INTEGER FCB'NXSO        = FCB'+19;                             <<04159>>06398000
LOGICAL FCB'LASTEXTSIZE = FCB'+20;                             <<04159>>06400000
INTEGER FCB'GN          = FCB'+22;                             <<04159>>06402000
INTEGER FCB'AN          = FCB'+26;                             <<04159>>06404000
DOUBLE FCB'START        = FCB'+30;                             <<04159>>06406000
DOUBLE FCB'END          = FCB'+32;                             <<04159>>06408000
DOUBLE FCB'HDR          = FCB'+34;                             <<04159>>06410000
DOUBLE ARRAY XMAP(0:MAXEXTENTS-1) = Q;   << local extent map >><<04159>>06412000
                                                               <<04159>>06414000
DEFINE READ = (CODE = 0)#,                                     <<04159>>06416000
   FCB'SECTPBLK = FCB'BFSPB.(8:8)#,                            <<04159>>06418000
   FCB'BLKFACT  = FCB'BFSPB.(0:8)#,                            <<04159>>06420000
   FCB'NUMEXTS  = FCB'NXSO.(11:5)#,                            <<04159>>06422000
   FCB'SECTOFF  = LOG(FCB'NXSO.(0:8))#,                        <<04159>>06424000
   FCB'MSGFILE  = (FCB'FOPTIONS.(2:3)=6)#,                     <<04159>>06426000
   FCB'CIRFILE  = (FCB'FOPTIONS.(2:3)=4)#,                     <<04159>>06428000
   FCB'VARIABLE = FCB'FOPTIONS.(9:1)#,                         <<04159>>06430000
   FCB'ASCII    = FCB'FOPTIONS.(13:1)#,                        <<04159>>06432000
   FCB'PERMANENT= FCB'FOPTIONS.(14:2)=1#,                      <<04159>>06434000
   FCB'MVTABX   = FCB'PVINFO.(4:4)#;                           <<04159>>06436000
                                                               <<04159>>06438000
<< ******  Begin subroutines  ****** >>                        <<04159>>06440000
                                                                        06442000
   SUBROUTINE ERREXIT(ERRNUM);                                          06444000
   VALUE ERRNUM; INTEGER ERRNUM;                                        06446000
      BEGIN                                                             06448000
      DEL;         << discard return address >>                         06450000
      CODE := TOS;      << ERRNUM >>                                    06452000
      GO EXIT                                                           06454000
      END;                                                              06456000
                                                                        06458000
   DOUBLE SUBROUTINE EXTENTPOOP (BLKNR);                                06460000
      << Determines the extent number and offset in sectors             06462000
     within the extent for the specified block.                         06464000
                                                                        06466000
        Input variable:                                                 06468000
            BLKNR - block number                                        06470000
                                                                        06472000
        Output variables:                                               06474000
            S-0   Offset within extent, sectors                         06476000
            S-1   Extent index (zero relative)    >>                    06478000
                                                                        06480000
   VALUE BLKNR;                                                         06482000
   DOUBLE BLKNR;                                                        06484000
      BEGIN                                                             06486000
      TOS := BLKNR+FCB'START;  <<FORM ACTUAL BLOCK NUMBER>>    <<HM.00>>06488000
      TOS := FCB'FLIM; <<FILE LIMIT IN RECORDS>>               <<HM.00>>06490000
      X := FCB'BLKFACT;  <<BLOCKING FACTOR>>                   <<HM.00>>06492000
      DIVD;                                                    <<HM.00>>06494000
      IF TOS <> 0 THEN TOS := TOS+1D;  <<FORM # FILE BLOCKS>>  <<HM.00>>06496000
      IF DS3 >= DS1 THEN ASSEMBLE(DSUB) ELSE DDEL; <<WRAP?>>   <<HM.00>>06498000
      X := FCB'SECTPBLK;                                                06500000
      MPYD;           << get total sectors >>                           06502000
      TOS := TOS+DOUBLE(FCB'SECTOFF);    << for labels >>               06504000
      TOS := FCB'EXTSIZE;  << extent size, sectors >>                   06506000
      ASMB(LDIV);                                                       06508000
      DS6 := TOS     << extent nr. and extent displ. >>                 06510000
      END;                                                              06512000
                                                                        06514000
   SUBROUTINE LABELIOSQ(RW);                                            06516000
   VALUE   RW;                                                          06518000
   INTEGER RW;                                                          06520000
      BEGIN                                                             06522000
      TOS := 0D;   << for result and LDEV >>                            06524000
      TOS := XMAP(0);                                                   06526000
      TOS := TOS&TASL(8)&DLSR(8);   << separate LDEV >>                 06528000
      X := FLABIO(*,*,S5,FLAB);    << R/W label >>                      06530000
      IF <> THEN                                                        06532000
         BEGIN                                                          06534000
         FLABIOERR(X,ACB'FNUM);                                         06536000
         RELSIR(FISIR,A);                                               06538000
         IF NOT SQEEZE THEN  << adjust squeeze bit in ODD >>            06540000
            XDDSPOOLINFO( 0D,%1001,XDDEP);                              06542000
         ERREXIT(LBLIOERR);                                             06544000
         END;                                                           06546000
      END;                                                              06548000
                                                                        06550000
   SUBROUTINE CLEARDISK(START,NSECTS);                                  06554000
   VALUE START, NSECTS; INTEGER NSECTS; DOUBLE START;                   06556000
                                                               <<04159>>06558000
   << DB is at stack.                                >>        <<04159>>06560000
   << Upper 8 bits  of START has the Ldev #, bottom  >>        <<04159>>06562000
   << 24 bits the sector address.                    >>        <<04159>>06564000
   <<                                                >>        <<04159>>06566000
      BEGIN                                                             06568000
      IF NSECTS = 0 THEN RETURN;                                        06570000
      TOS := 0;      << for result of FCLEAR >>                         06572000
                                                               <<04450>>06574000
      << Want to clear RIO files with zeroes, even if ASCII >> <<04450>>06576000
      << to clear the ART with zeroes.                      >> <<04450>>06578000
                                                               <<04450>>06580000
      TOS := IF (ACB'RIO OR (NOT FCB'ASCII))                   <<04450>>06582000
               THEN FALSE ELSE TRUE;                           <<04450>>06584000
      TOS := 0;      << for LDEV >>                                     06586000
      TOS := DS6;    << START - LDEV and sector nr.>>                   06588000
      TOS := TOS&TASL(8)&DLSR(8);  << separate LDEV >>                  06590000
      X := FCLEAR(*,*,*,S6);   << (ASC,LDEV,SECTOR,NSECTS) >>           06592000
$  IF X1 = ON                                                           06594000
      IF <> THEN FTROUBLE(475);  << error >>                            06596000
$  IF                                                                   06598000
      END;                                                              06602000
                                                                        06604000
$ PAGE                                                                  06606000
<< ******  FCONVBLK: Begin execution  ****** >>                         06608000
                                                                        06610000
$  IF X0 = ON                                                           06612000
   IF MONUNCALLABLE THEN  << Monitoring? >>                             06614000
      BEGIN                                                             06616000
      FTITLE("FCON","VBLK",0D,0D);                                      06618000
      DEBUG                                                             06620000
      END;                                                              06622000
$  IF                                                                   06624000
   ACBQ := LDEV-DELTAQ;   << get our ACB Q-rel index >>                 06626000
                                                                        06628000
<< Special treatment for Foreign Disk request. >>                       06630000
                                                                        06632000
   IF ACB'DTYPE=FDISC THEN                                              06634000
      BEGIN                                                             06636000
      CODE := 0;    << Initially assume OK >>                           06638000
      LDEV := ACB'DADDR;                                       <<01672>>06640000
      FCEOF := DISCSIZE(LDEV);                                 <<01672>>06642000
      STX := INTEGER(FCEOF-BLOCK);                             <<01672>>06644000
      IF <= THEN                                               <<01672>>06646000
         CODE := 2;   << Beyond FLIM. >>                                06648000
      RETURN 0;                                                         06650000
      END;                                                              06652000
                                                                        06654000
   <<* * * Save info from ACB * * *>>                                   06656000
                                                                        06658000
   DX := -1;     << Reset EXCHANGEDB flag >>                            06660000
   @XDDEP := ACB'SPXDDX;                                                06662000
   TOS := ACB'SPOOLED;                                                  06664000
   IF = THEN                                                   <<HM.00>>06666000
      BEGIN   <<NOT A USER SPOOL FILE>>                        <<HM.00>>06668000
      IF TOS <> ACB'SPXDDX AND NOT ACB'MSGFILE THEN            <<HM.00>>06670000
         TOS:=TRUE  <<SPOOLER FILE>>                           <<HM.00>>06672000
      ELSE                                                     <<HM.00>>06674000
         TOS:=FALSE;  <<NOT ANY TYPE OF SPOOL FILE>>           <<HM.00>>06676000
      END;                                                     <<HM.00>>06678000
   SPOOLF:=TOS;                                                <<HM.00>>06680000
   SQEEZE := IF INTEGER(SPOOLF) < 0 THEN ACB'SPSQZ ELSE 0;              06682000
                                                                        06684000
   <<* * * Copy FCB to Q + FCBMQ buffer * * *               >> <<04578>>06686000
   << The FCB's Q-rel offset is %XX. This will need to be  >>  <<04450>>06688000
   << changed if there are any changes in the declarations >>  <<04159>>06690000
                                                                        06692000
   GET'FCB'PRIME'Q'LOC;                                        <<04578>>06694000
                                                               <<04159>>06696000
   LOCK'CB(0,0,FCBMQ,ACB'FCB.DSTN,ACB'FCB VTA);                <<04578>>06698000
   TOS := SIZEBFCB;    << excluding E-map >>                            06700000
   MOVE'DS'1;          << get FCB, incl. E-map size >>                  06702000
   X := FCB'.(2:14);   << FCB size >>                                   06704000
   IF BADFCBSIZE THEN FTROUBLE(61);                                     06706000
   EMAPADDR := DS1;    << save FCB e-map location >>                    06708000
   TOS := (FCB'NUMEXTS+1)&LSL(1);                                       06710000
   MOVE'DS'6;          << get the E-map >>                              06712000
   FCEOF := FCB'EOF;    << return parameter >>                          06714000
                                                                        06716000
                                                                        06718000
   <<* * * Get block nr. and extent index * * *>>                       06720000
                                                                        06722000
   BLKFACT := DOUBLE(FCB'BLKFACT);                                      06724000
   IF BLOCK < 0D THEN ERREXIT(BADRECNO)                        <<02068>>06726000
   ELSE IF BLOCK > (FCB'FLIM-1D)/BLKFACT THEN                  <<02068>>06728000
      ERREXIT(2);        << Bad address; throw the bum out. >>          06730000
   NEWEXTD := EXTENTPOOP(BLOCK);  << Get extent nr. & displ. >>         06732000
   NEWEXTSIZE := EXTSIZE := IF NEWEXTX < FCB'NUMEXTS           <<04653>>06734000
      THEN FCB'EXTSIZE ELSE FCB'LASTEXTSIZE;                            06736000
                                                               <<04564>>06738000
   <<*******************************************************>> <<04564>>06740000
   << Calculate the old EOF block number and report EOF if  >> <<04564>>06742000
   << reading past this block number.  The FCB EOF/END check>> <<04770>>06744000
   << is to protect pre MPE-IV variable files since these   >> <<04770>>06746000
   << files do not have FCB'END set to the EOF block numb.  >> <<04770>>06748000
   <<*******************************************************>> <<04564>>06750000
                                                               <<04564>>06752000
   IF FCB'VARIABLE                                             <<04564>>06754000
      THEN OLDEOFBLK :=  FCB'END - FCB'START + 1D              <<04564>>06756000
      ELSE OLDEOFBLK := (FCB'EOF + BLKFACT - 1D) / BLKFACT;    <<04564>>06758000
   IF READ AND BLOCK >= OLDEOFBLK AND NOT ACB'MSGFILE AND      <<04770>>06760000
      NOT (FCB'VARIABLE LAND FCB'EOF <> 0D LAND FCB'END = 0D)  <<04770>>06762000
      THEN ERREXIT(1);            << Report EOF             >> <<04564>>06764000
                                                                        06766000
<< If reading spoofle, skip over deleted extents. >>                    06768000
                                                                        06770000
   Z := 1;                                                              06772000
   IF READ AND SQEEZE THEN      << reading squeezed spoofle >>          06774000
      BEGIN             << find first non-deleted extent. >>            06776000
      WHILE XMAP(Z) = 0D DO Z := Z+1;                                   06778000
      IF NEWEXTX < Z AND Z > 1 THEN                                     06780000
         BEGIN           << Addressing a deleted extent. >>             06782000
         NEWEXTX := Z;    << Go to first existing extent >>             06784000
         NEWEXTO := 0;                                                  06786000
         TOS := BLOCK := (DOUBLE(Z)*DOUBLE(FCB'EXTSIZE)                 06788000
            -DOUBLE(FCB'SECTOFF))/DOUBLE(FCB'SECTPBLK);                 06790000
         ACB'BLKLO := TOS;                                              06792000
         AQ0(X := X-1) := TOS;   << Adjust BLK pointer in ACB >>        06794000
         END;                                                           06796000
      END;                                                              06798000
   IF NEWEXTX > FCB'NUMEXTS THEN ERREXIT(2);                            06800000
                                                                        06802000
<< ****  If the new extent hasn't been allocated, do so,                06804000
   and clear it up to the new block if advancing EOF.                   06806000
   If not advancing EOF, clear the entire new extent.   ****  >>        06808000
                                                                        06810000
   IF XMAP(NEWEXTX) = 0D AND CODE <> %11 THEN                  <<01936>>06812000
      BEGIN          << Extent not yet allocated. >>                    06814000
                                                               <<04567>>06816000
      <<****************************************************>> <<04567>>06818000
      << If we are reading from an un-allocated extent, re- >> <<04567>>06820000
      << turn with an "error".  IOMOVE will then simply fill>> <<04567>>06822000
      << the needed buffers will fill characters. This will >> <<04567>>06824000
      << save much time and disc space!                     >> <<04567>>06826000
      <<****************************************************>> <<04567>>06828000
                                                               <<04567>>06830000
      IF READ THEN                                             <<04567>>06832000
         BEGIN                                                 <<04567>>06834000
         STX := NEWEXTSIZE - NEWEXTO;  << Sectors avb. ext. >> <<04567>>06836000
         BLOCK := 0D;                  << No extent address.>> <<04567>>06838000
         LDEV  := 0;                                           <<04567>>06840000
         ERREXIT(UNALLOC'EXT);         <<  Report "error".  >> <<04567>>06842000
         END;                                                  <<04567>>06844000
                                                               <<04567>>06846000
      IF FCB'PERMANENT AND ACB'ACCESS.(11:2)=0                          06848000
          AND ACB'ACCESS.(14:1)=0 THEN                                  06850000
         ERREXIT(2);   << Can't extend; report beyond file limit. >>    06852000
                                                                        06854000
   << Adjust directory disc space counts.  Runs with DB at stack. >>    06856000
                                                                        06858000
      IF PCB'XDS <> 0 THEN DX := EXCHANGEDB(0);                         06860000
      IF FCB'PERMANENT THEN                                             06862000
         BEGIN           << Old permanent file. >>                      06864000
         DJ1J2 := DIRECADJUST(DOUBLE(NEWEXTSIZE),0,                     06866000
            FCB'AN,FCB'GN,FCB'MVTABX);                                  06868000
         IF <> THEN                                                     06870000
            ERREXIT(IF < THEN DIRIOERR ELSE J1+NORIN);  <<%74>>         06872000
         END;     << old permanent file >>                              06874000
                                                                        06876000
      <<* * * Allocate disk space for new extent * * *>>                06878000
                                                                        06880000
      IF SPOOLF AND XDDSPOOLINFO(0D,%400,XDDEP) <> 0D THEN              06882000
         ERREXIT(SPOOLNOSPACE);     << NOSPACE bit was set >>           06884000
      XMAP(NEWEXTX) := DOUBLE(NEWEXTSIZE);  << amt. needed >>           06886000
      j1 := Diskalloc (IF spoolf THEN 0 ELSE fcb'device,       <<03503>>06888000
                       1, xmap(newextx), fcb'pvinfo).(8:8);    <<03503>>06890000
      IF <> THEN                                                        06892000
         BEGIN          << Error allocating space. >>                   06894000
         XMAP(NEWEXTX) := 0D;     << Poof! >>                           06896000
         IF j1 = 1 THEN    << No disc space? >>                <<03503>>06898000
            IF NOT SPOOLF THEN                                          06900000
               TOS := NOSPACE                                           06902000
            ELSE                                                        06904000
               BEGIN                                                    06906000
               TOS := SPOOLNOSPACE;                                     06908000
               XDDSPOOLINFO(0D,%200,XDDEP) <<set NOSPACE bit>>          06910000
               END                                                      06912000
         ELSE IF j1 = 2 THEN   << I/O error >>                 <<03503>>06914000
            TOS := IF SPOOLF THEN SPOOLERROR ELSE DISCIOERR             06916000
         ELSE IF j1 = 4 THEN   << Device not avail? >>         <<03503>>06918000
            TOS := NAVAILDEV                                            06920000
         ELSE IF j1 = 3 THEN                                   <<03503>>06922000
            TOS := disc'space'allocation'disabled              <<03503>>06924000
         ELSE                                                           06926000
            BEGIN      << Other error. >>                               06928000
$  IF X1 = ON                                                           06930000
            FTROUBLE(468);                                              06932000
$  IF                                                                   06934000
            TOS := IF SPOOLF THEN SPOOLERROR ELSE SYSTEM                06936000
            END;                                                        06938000
         IF FCB'PERMANENT THEN                                          06940000
            BEGIN      << Reset directory space counts. >>              06942000
            DJ1J2 := DIRECADJUST(-DOUBLE(NEWEXTSIZE),0,                 06944000
               FCB'AN,FCB'GN,FCB'MVTABX);                               06946000
$  IF X1 = ON                                                           06948000
            IF <> THEN FTROUBLE(468);      << Error >>                  06950000
$  IF                                                                   06952000
            END;                                                        06954000
         ERREXIT(*);                                                    06956000
         END;       << error allocating space >>                        06958000
      IF SPOOLF THEN    << bump nr. of extents >>              <<01672>>06960000
         XDDSPOOLINFO(0D,%100,XDDEP);                          <<01672>>06962000
                                                                        06964000
   << Update extent map entry in FCB. >>                                06966000
                                                                        06968000
      TOS := EMAPADDR;       << DST and offset >>                       06970000
      TOS := TOS+NEWEXTX&LSL(1);                                        06972000
      TOS := @XMAP(NEWEXTX);                                            06974000
      TOS := 2;                                                         06976000
      ASMB(MTDS 4);                                                     06978000
                                                                        06980000
                                                                        06982000
   << Update extent map in file label.  The dance with the FCB          06984000
      maintains resource hierarchy.  >>                                 06986000
                                                                        06988000
      UNLOCK'CB(0,ACB'FCB.DSTN,ACB'FCB VTA);  << release FCB >>         06990000
      IF NOT ACB'EXCL  THEN A := GETSIR(FISIR);                <<04160>>06992000
      LOCK'CB(0,0,1,ACB'FCB.DSTN,ACB'FCB VTA);   << get it back >>      06994000
      ASMB(SUBS 5);      << discard results >>                          06996000
      PUSH (S);                                                         06998000
      @FLAB := TOS+1;                                                   07000000
      ASMB (ADDS 128);                                                  07002000
      LABELIOSQ(0);      << Read label into stack buffer >>             07004000
      FLEOF := FCB'EOF;                                                 07006000
      FLSTART:=FCB'START;                                      <<HM.00>>07008000
      FLEND:=FCB'END;                                          <<HM.00>>07010000
      FLHDRECS:=FCB'HDR;                                       <<HM.00>>07012000
      LDEVTOVTAB(FLEXTMAP,XMAP,FLNUMEXTS+1,FCB'MVTABX<>0);              07014000
      LABELIOSQ(1);         << Rewrite label >>                         07016000
      ASMB (SUBS 128);                                                  07018000
      IF NOT ACB'EXCL  THEN RELSIR(FISIR,A);                   <<04160>>07020000
                                                                        07022000
   <<  If variable or not advancing EOF, clear all of new extent.  >>   07024000
                                                                        07026000
      IF BLOCK < OLDEOFBLK OR FCB'VARIABLE THEN                <<04564>>07028000
         CLEARDISK(XMAP(NEWEXTX),NEWEXTSIZE);                           07030000
      END;       << extent not yet allocated >>                         07032000
                                                                        07034000
<< ****  If fixed, and the block is beyond the prior EOF, clear any     07036000
   allocated space from the prior EOF to the new block.  >>             07038000
                                                                        07040000
   IF BLOCK > OLDEOFBLK AND                                    <<04564>>07042000
      NOT FCB'MSGFILE AND NOT FCB'VARIABLE THEN                <<04564>>07044000
      BEGIN             << New block is beyond prior EOF. >>            07046000
      OLDEOFD := EXTENTPOOP(OLDEOFBLK);                                 07048000
      IF XMAP(OLDEOFX) <> 0D THEN   << clear in old EOF extent >>       07050000
         CLEARDISK(XMAP(OLDEOFX)+DOUBLE(OLDEOFO),                       07052000
            IF OLDEOFX=NEWEXTX THEN   << advancing in old extent >>     07054000
               NEWEXTO-OLDEOFO   << clear from EOF to new block >>      07056000
            ELSE        << clear all the rest of old EOF extent >>      07058000
               FCB'EXTSIZE-OLDEOFO);                                    07060000
                                                                        07062000
                                                                        07064000
<<  Clear from beginning of new extent to block containing new EOF. >>  07066000
                                                                        07068000
      IF NEWEXTX > OLDEOFX AND XMAP(NEWEXTX) <> 0D THEN        <<01936>>07070000
         CLEARDISK(XMAP(NEWEXTX),NEWEXTO);                              07072000
                                                                        07074000
<< Clear any intervening allocated extents. >>                          07076000
                                                                        07078000
      WHILE (OLDEOFX := OLDEOFX+1) < NEWEXTX DO                         07080000
         IF XMAP(OLDEOFX) <> 0D THEN    << it exists - clear it >>      07082000
            CLEARDISK(XMAP(OLDEOFX),FCB'EXTSIZE);                       07084000
      END;    << new block allocated beyond EOF >>                      07086000
                                                                        07088000
   <<* * * Return parameters * * *>>                                    07090000
                                                                        07092000
   STX := NEWEXTSIZE-NEWEXTO;  << sectors avbl in extent >>             07094000
   TOS := CODE;                                                         07096000
   IF BLOCK >= OLDEOFBLK AND NOT FCB'VARIABLE                  <<04564>>07098000
      THEN CODE := 1         << Report EOF                  >> <<04564>>07100000
      ELSE CODE := 0;        << No EOF to report            >> <<04564>>07102000
   TOS := 0;              << for LDEV >>                                07104000
   TOS := XMAP(NEWEXTX);    << extent descriptor >>                     07106000
   TOS := EXTBASE := TOS & TASL(8) & DLSR(8); << strip ldev >> <<04653>>07108000
   BLOCK := TOS+DOUBLE(NEWEXTO);  << sector nr. of block >>             07110000
   LDEV := TOS;                 << LDEV of block >>                     07112000
                                                                        07114000
   IF TOS = 0 AND ACB'SPRSQ AND                                         07116000
       NEWEXTX > Z AND NEWEXTO >= NEWEXTSIZE/2 THEN                     07118000
                                                                        07120000
<< When reading a spoofle with squeezing requested, deletes extent      07122000
"Z" when we've read halfway into the next extent.  Runs with DB         07124000
at stack for DISKDEALLOC.  Since the spooler has exclusive access,      07126000
it isn't necessary to release and reacquire the FCB.  >>                07128000
                                                                        07130000
      BEGIN       << Halfway into new extent. >>                        07132000
      IF SQEEZE THEN                                                    07134000
         BEGIN           << Perform a squeeze. >>                       07136000
         IF DX = -1 THEN DX := EXCHANGEDB(0);   << to stack >>          07138000
         IF NOT ACB'EXCL  THEN A := GETSIR(FISIR);             <<04160>>07140000
         PUSH(S);                                                       07142000
         @FLAB := TOS+1;                                                07144000
         ASMB(ADDS 128);       << allot label buffer >>                 07146000
         LABELIOSQ(0);         << read file label >>                    07148000
         TOS := @FLEXTMAP;                                              07150000
         DPS0(Z) := 0D;        << clear label E-map entry >>            07152000
         DEL;                                                           07154000
         LABELIOSQ(1);         << rewrite file label >>                 07156000
         ASMB(SUBS 128);       << dealloc stack buffer >>               07158000
         IF NOT ACB'EXCL  THEN RELSIR(FISIR,A);                <<04160>>07160000
         X := DISKDEALLOC(FCB'EXTSIZE,FCB'EXTSIZE,%201,XMAP(Z));        07162000
$  IF X1 = ON                                                           07164000
         IF <> THEN FTROUBLE(468);    << if error >>                    07166000
$  IF                                                                   07168000
         XMAP(Z) := 0D;        << clear ext map entry >>                07170000
         TOS := EMAPADDR;                                               07172000
         TOS := TOS+Z&LSL(1);                                           07174000
         TOS := @XMAP(Z);                                               07176000
         TOS := 2;                                                      07178000
         ASMB(MTDS 4);                                                  07180000
         END           << perform squeeze >>                            07182000
      ELSE                                                              07184000
         BEGIN     << not squeezing yet >>                              07186000
         TOS := ACB'SPFL;                                               07188000
         TOS.(2:1) := 1;   << ACB'SPSQZ: indicate squeezing >>          07190000
         ACB'SPFL := TOS;                                               07192000
         XDDSPOOLINFO(0D,%1001,XDDEP);                                  07194000
         END;                                                           07196000
      END;        << new extent >>                                      07198000
                                                                        07200000
EXIT:                                                                   07202000
   IF DX <> -1 THEN EXCHANGEDB(DX);  << back to user buff >>            07204000
   UNLOCK'CB(0,ACB'FCB.DSTN,ACB'FCB VTA);  << release FCB >>            07206000
   RETURN 0                                                             07208000
   END;        << procedure FCONV'BLK >>                                07210000
$PAGE " ODDS AND ENDS "                                        <<02545>>07212000
$CONTROL SEGMENT=FILESYS1A  <<FADJUSTCIRFILE>>                 <<HM.00>>07214000
PROCEDURE FADJUSTCIRFILE(NUMRECORDS,ACBQ);                     <<HM.00>>07216000
                                                               <<HM.00>>07218000
   << Used by writers to correct file overflow.                  HM.00  07220000
     Input variables:                                            HM.00  07222000
         NUMRECORDS - number of records in the block             HM.00  07224000
         ACBQ       - caller's Q-rel ACB location >>           <<02076>>07226000
   VALUE NUMRECORDS,ACBQ;                                      <<HM.00>>07228000
                                                               <<HM.00>>07230000
   DOUBLE NUMRECORDS;                                          <<HM.00>>07232000
   INTEGER ACBQ;                                               <<HM.00>>07234000
   OPTION PRIVILEGED,UNCALLABLE;                               <<HM.00>>07236000
   BEGIN                                                       <<HM.00>>07238000
   INTEGER ARRAY FCB'(0:SIZEBFCB-1)=Q;  << must be 1st decl >> <<02076>>07240000
   LOGICAL FCB'FOPTIONS  = FCB'+2;                             <<HM.00>>07242000
   INTEGER FCB'BFSPB     = FCB'+18;                            <<HM.00>>07244000
   DEFINE  FCB'BLKFACT   = FCB'BFSPB.(0:8)#,                   <<HM.00>>07246000
           FCB'VARIABLE  = FCB'FOPTIONS.(9:1)#;                <<HM.00>>07248000
   DOUBLE  FCB'FLIM      = FCB'+10,                            <<HM.00>>07250000
           FCB'EOF       = FCB'+14,                            <<HM.00>>07252000
           FCB'START     = FCB'+30,                            <<HM.00>>07254000
           FCB'END       = FCB'+32;                            <<HM.00>>07256000
   DEFINE  ACB'FCB       = AQ0(ACBQ+26)#;                      <<HM.00>>07258000
                                                               <<HM.00>>07260000
$  IF X0 = ON                                                  <<HM.00>>07262000
   IF MONOTHER THEN  <<MONITORING?>>                           <<HM.00>>07264000
      BEGIN                                                    <<HM.00>>07266000
      TOS := "FA"; TOS := "DJ"; TOS := "US"; TOS := "TC";      <<HM.00>>07268000
      TOS := "IR"; TOS := "FI"; TOS := "LE";                   <<HM.00>>07270000
      ASSEMBLE(ZERO);                                          <<HM.00>>07272000
      FTITLE(*,*,*,*);                                         <<HM.00>>07274000
      DEBUG                                                    <<HM.00>>07276000
      END;                                                     <<HM.00>>07278000
$  IF                                                          <<HM.00>>07280000
                                                               <<HM.00>>07282000
   <<* * * Get local copy of the FCB * * *>>                   <<02076>>07284000
                                                               <<HM.00>>07286000
   ACBQ := ACBQ-DELTAQ;    << get our ACB Q-rel address >>     <<02076>>07288000
   LOCK'CB(8,0,1,ACB'FCB.DSTN,ACB'FCB VTA);                    <<HM.00>>07290000
   TOS := SIZEBFCB;                                            <<02076>>07292000
   ASMB(MDS 1);                                                <<HM.00>>07294000
                                                               <<HM.00>>07296000
   FCB'START := FCB'START+1D;                                  <<02076>>07298000
   IF FCB'START >= FCB'FLIM/DBL(FCB'BLKFACT) THEN              <<HM.00>>07300000
      FCB'START := 0D;                                         <<02076>>07302000
   IF FCB'VARIABLE THEN FCB'END := FCB'END-1D;                 <<02076>>07304000
   FCB'EOF := FCB'EOF-NUMRECORDS;                              <<02076>>07306000
   S2 := S2-1;    << decrement addresses for move back >>      <<02076>>07308000
   TOS := TOS-1;                                               <<02076>>07310000
   ASMB(DXCH);                                                 <<HM.00>>07312000
   TOS := -SIZEBFCB;                                           <<02076>>07314000
   ASMB(MDS 5);                                                <<HM.00>>07316000
                                                               <<HM.00>>07318000
   <<* * * Unlock FCB * * *>>                                  <<02076>>07320000
                                                               <<HM.00>>07322000
   IF LOGICAL(TOS) THEN UNLOCK'CB(0,ACB'FCB.DSTN,              <<HM.00>>07324000
      ACB'FCB VTA) ELSE PSEUDOENABLE;                          <<HM.00>>07326000
   END;     << procedure FADJUSTCIRFILE >>                     <<02076>>07328000
PROCEDURE SET'LPDT'BOT(LDEV,VAL);                              <<02545>>07330000
VALUE LDEV,VAL; LOGICAL LDEV,VAL;                                       07332000
OPTION PRIVILEGED,UNCALLABLE;                                           07334000
                                                                        07336000
<< Set or reset Beginning-of-Tape bit in LPDT entry. >>                 07338000
                                                                        07340000
   BEGIN                                                                07342000
   DISABLE;                                                             07344000
   LPDT'BOT := VAL;                                                     07346000
   ENABLE;                                                              07348000
   END;      << procedure SET'LPDT'BOT >>                               07350000
DOUBLE PROCEDURE WRITE'DENSITY(LDEV);                          <<02652>>07352000
   VALUE LDEV; INTEGER LDEV;                                   <<02570>>07354000
   OPTION PRIVILEGED,UNCALLABLE;                               <<02570>>07356000
                                                               <<02570>>07358000
COMMENT  << beginning of comment >>                            <<02570>>07360000
                                                               <<02570>>07362000
   This procedure sets the density of a multiple density       <<02570>>07364000
mag tape drive.  The procedure returns the double word         <<02652>>07366000
returned by ATTACHIO.  If the ATTACHIO was successful, the     <<02652>>07368000
procedure also clears the LPDT'BOT bit to take the burden off  <<02570>>07372000
of the calling procedure.  Thus, WRITE'DENSITY should only be  <<02570>>07374000
called if a write ATTACHIO call follows immediately.           <<02570>>07376000
                                                               <<02570>>07378000
NOTE:  1) The caller must only pass devices (LDEV) which are   <<02570>>07380000
          known to be mag. tape drives.  All other checks      <<02570>>07382000
          are handled internal to the procedure.               <<02570>>07384000
       2) DB may be anywhere when calling this procedure.      <<02570>>07386000
          Typically, it will be at the user's buffer.          <<02570>>07388000
       3) Because the ATTACHIO call is an infrequent event     <<02570>>07390000
          compared with other file system activity (it only    <<02570>>07392000
          occurs when a write function occurs at load point),  <<02570>>07394000
          the overhead of an EXCHANGEDB and a table lock is    <<02570>>07396000
          considered acceptable.                               <<02570>>07398000
                                                               <<02570>>07400000
<< end of comment >>;                                          <<02570>>07402000
                                                               <<02570>>07404000
BEGIN                                                          <<02570>>07406000
DOUBLE                                                         <<02652>>07408000
   RESULT = WRITE'DENSITY;  << Return value >>                 <<02652>>07410000
INTEGER                                                        <<02652>>07412000
   IO'STAT = RESULT,    << ATTACHIO status return >>           <<02652>>07414000
   IO'TLOG = RESULT+1;  << ATTACHIO transmission log >>        <<02652>>07416000
INTEGER                                                        <<02570>>07418000
   LDT'DENW,     << LDT entry density information >>           <<02570>>07420000
   DENW'INDEX,   << Index into LDT to get LDT'DENW >>          <<02570>>07422000
   NEW'TAPE,     << Save first REQUEST'DENSITY >>              <<02570>>07424000
   ATTIO'STAT,   << Holds ATTACHIO status return >>            <<02570>>07426000
   P2,           << Parameter 2 to ATTACHIO >>                 <<02570>>07428000
   OLDDB,                                                      <<02570>>07430000
   SAVESIR;                                                    <<02570>>07432000
EQUATE                                                         <<02570>>07434000
   P2'6250     = 0,     << P2 value for 6250 BPI >>            <<02570>>07436000
   P2'1600     = 1,     << P2 value for 1600 BPI >>            <<02570>>07438000
   OK'MASK     = %4007, << Test subtype.(13:3) and BOT bit >>  <<02570>>07440000
   OK'VALUE    = %4001, << HP7976A at load point >>            <<02570>>07442000
   DEN'FUNC    = 16,    << Density function of driver >>       <<02570>>07444000
   SUCCESSFUL  = 1,     << General status, successful >>       <<02570>>07446000
   PFAIL'ABORT = %63,   << Power fail abort status >>          <<02570>>07448000
   POWER'UP    = %213,  << Device powered up status >>         <<02570>>07450000
   NOT'AT'BOT  = %233;  << Device not at load point status >>  <<02570>>07452000
                                                               <<02570>>07454000
                                                               <<02570>>07456000
   IO'STAT := SUCCESSFUL;  << Initialize return >>             <<02652>>07458000
                                                               <<02570>>07460000
   << Check to see that LDEV is an HP7976A at load point. >>   <<02570>>07462000
   IF (LPDT (LOGICAL(LDEV)*LPDTENTRY + 1) LAND OK'MASK) <>     <<04321>>07464000
      OK'VALUE THEN GO EXIT;   << It isn't.                 >> <<04321>>07466000
                                                               <<02570>>07468000
   OLDDB := EXCHANGEDB(0);                                     <<02570>>07470000
                                                               <<02570>>07472000
   << Get density information from LDT entry >>                <<02570>>07474000
   TOS := @LDT'DENW;                                           <<02570>>07476000
   TOS := LDT;                                                 <<02570>>07478000
   TOS := DENW'INDEX := LDEV*LDTENTRY + DENSITYW;              <<02570>>07480000
   TOS := 1;                                                   <<02570>>07482000
   ASSEMBLE( MFDS 4 );                                         <<02570>>07484000
                                                               <<02570>>07486000
<< Originally, there was code here to skip the ATTACHIO if   >><<02570>>07488000
<< (TAPE'DENSITY=REQUEST'DENSITY) was TRUE.  This will not   >><<02570>>07490000
<< work if a user is doing his own unlabelled tape reel      >><<02570>>07492000
<< management.  When the 2nd or later reel comes "on line",  >><<02570>>07494000
<< AVR does not occur because the drive is already owned.    >><<02570>>07496000
<< Therefore, TAPE'DENSITY will not reflect the density of   >><<02570>>07498000
<< the new tape on the drive, but the previous tape on the   >><<02570>>07500000
<< drive.  Therefore, the test is invalid and the ATTACHIO   >><<02570>>07502000
<< must always be done. >>                                     <<02570>>07504000
                                                               <<02570>>07506000
   P2 := IF REQUEST'DENSITY = DEN'1600 THEN P2'1600            <<02570>>07508000
                                       ELSE P2'6250;           <<02570>>07510000
                                                               <<02570>>07512000
   << Retry set density if power problems >>                   <<02570>>07514000
   DO BEGIN                                                    <<02570>>07516000
      RESULT := ATTACHIO(LDEV,0,0,0,DEN'FUNC,0,0,P2,BFLAGS);   <<02652>>07518000
      ATTIO'STAT := IO'STAT.(8:8);                             <<02652>>07522000
      END                                                      <<02570>>07524000
   UNTIL (ATTIO'STAT <> POWER'UP) AND                          <<02570>>07526000
         (ATTIO'STAT <> PFAIL'ABORT);                          <<02570>>07528000
                                                               <<02570>>07530000
   IF ATTIO'STAT.(13:3) <> SUCCESSFUL THEN                     <<02570>>07532000
      BEGIN                                                    <<02570>>07534000
      << If not at load point, then data structure got  >>     <<02570>>07536000
      << messed up.  Ignore it !!  Report other errors. >>     <<02570>>07538000
      IF ATTIO'STAT = NOT'AT'BOT THEN                          <<02652>>07540000
         IO'STAT.(8:8) := SUCCESSFUL;                          <<02652>>07542000
      END                                                      <<02570>>07544000
   ELSE                                                        <<02570>>07546000
      BEGIN   << Success >>                                    <<02570>>07548000
      SAVESIR := GETSIR(LDTSIR);                               <<02570>>07550000
                                                               <<02570>>07552000
      NEW'TAPE := REQUEST'DENSITY; << Save new density >>      <<02570>>07554000
                                                               <<02570>>07556000
      << Get current density info from LDT >>                  <<02570>>07558000
      TOS := @LDT'DENW;                                        <<02570>>07560000
      TOS := LDT;                                              <<02570>>07562000
      TOS := DENW'INDEX;                                       <<02570>>07564000
      TOS := 1;                                                <<02570>>07566000
      ASSEMBLE( MFDS 4 );                                      <<02570>>07568000
                                                               <<02570>>07570000
      << Update tape density with new density >>               <<02570>>07572000
      TAPE'DENSITY := NEW'TAPE;                                <<02570>>07574000
                                                               <<02570>>07576000
      << Write it back >>                                      <<02570>>07578000
      TOS := LDT;                                              <<02570>>07580000
      TOS := DENW'INDEX;                                       <<02570>>07582000
      TOS := @LDT'DENW;                                        <<02570>>07584000
      TOS := 1;                                                <<02570>>07586000
      ASSEMBLE( MTDS 4 );                                      <<02570>>07588000
                                                               <<02570>>07590000
      RELSIR(LDTSIR,SAVESIR);                                  <<02570>>07592000
      END;                                                     <<02570>>07594000
                                                               <<02570>>07596000
   EXCHANGEDB(OLDDB);   << Put it back >>                      <<02570>>07598000
                                                               <<02570>>07600000
EXIT:                                                          <<02570>>07602000
   IF IO'STAT.(8:8) = SUCCESSFUL THEN                          <<02652>>07606000
      SET'LPDT'BOT(LDEV,0);   << Write will follow >>          <<02570>>07608000
                                                               <<02570>>07610000
END;   << of WRITE'DENSITY >>                                  <<02570>>07612000
$PAGE " IOMOVE - DEFINITIONS AND SUBROUTINES "                          07614000
$CONTROL SEGMENT = FILESYS1A  << IOMOVE >>                              07616000
                                                                        07618000
PROCEDURE IOMOVE(MODE,TARGET,TCOUNT);                                   07620000
   VALUE MODE,TCOUNT;                                                   07622000
                                                                        07624000
   << This procedure does all record I/O.                               07626000
                                                                        07628000
     Input variables:                                                   07630000
         MODE - I/O mode                                                07632000
            0  Input (FREADDIR)                                         07634000
            2  Control (spoolfile WRITE)                                07636000
            3  FOPEN   (      ..       )                                07638000
            4  FCLOSE  (      ..       )                                07640000
            %26 OR %36  FREADBACKWARD                                   07642000
          %10  FREADSEEK                                                07644000
          %20  Input (FREAD)                                            07646000
          %30  Input - no-wait I/O initiation (FREAD)                   07648000
          %40  Input - no-wait I/O completion (IOWAIT)                  07650000
          %40  RIO - delete active record.                              07652000
          %50  RIO - only return activity state (no data)               07654000
            1  Output (FWRITEDIR)                              <<DONTW  07656000
          %11  Write EOF - insure extents are initialized        FIXIT  07658000
          %21  Output (FWRITE)                                 <<DONTW  07660000
          %31  Output - no-wait I/O initiation (FWRITE)                 07662000
          %41  Output - no-wait I/O completion (IOWAIT)                 07664000
       >=%100  Output - FDEVICECONTROL function                <<CIPER  07666000
         TARGET - pointer to user's buffer                              07668000
         TCOUNT - transfer count (pos. words/neg. bytes)                07670000
                                                                        07672000
     All errors are indicated via ACBSTATUS, ACBLSTATE (EOF flag)       07674000
     and ACBERROR.  DB must be set to the data segment containing       07676000
     the user's buffer.  In order to permit direct rather than          07678000
     indexed addressing, the ACB is assumed to lie directly beneath     07680000
     the explicit parameters to IOMOVE; callers must not stack          07682000
     any data before calling IOMOVE.    >>                              07684000
                                                                        07686000
   INTEGER TCOUNT;                                                      07688000
   LOGICAL ARRAY TARGET;                                                07690000
   LOGICAL MODE;                                                        07692000
   OPTION PRIVILEGED,UNCALLABLE;                                        07694000
                                                                        07696000
BEGIN                                                                   07698000
                                                               <<04653>>07700000
<< The following EQUATEs are used to identIFy the "type" >>    <<04653>>07702000
<< of ATTACHIO IOMOVE is attempting to perform to the MPE>>    <<04653>>07704000
<< I/O system.  It will hopefully indicate sequential and>>    <<04653>>07706000
<< BUF/NOBUF states to ATTACHIO via FLAGS.(0:4).         >>    <<04653>>07708000
EQUATE BUF'FLUSH     = 9,   << FQUIESCEIO >>                   <<04653>>07710000
       NOBUF'SEQ     = 10,                                     <<04653>>07712000
       NOBUF'DIR     = 11,                                     <<04653>>07714000
       BUF'SEQ       = 12,                                     <<04653>>07716000
       BUF'DIR       = 13,                                     <<04653>>07718000
       NOBUF'KSAM    = 14,                                     <<04653>>07720000
       NOBUF'IMAGE   = 15;                                     <<04653>>07722000
                                                               <<04653>>07724000
DEFINE FLG'CNTL = (0:4)#;   << ATTACHIO FLAG word type field >><<04653>>07726000
                                                               <<04653>>07728000
EQUATE                                                         <<04321>>07730000
   MIN'MODE'FDEVICECONTROL = %100;                             <<04321>>07732000
DEFINE ACBMQ =-63#;  << Q-rel locn of ACB. >>                           07734000
INTEGER ARRAY ACB(*) = Q ACBMQ;                                         07736000
   INTEGER ACB'FNUM     = ACB+1;                                        07738000
   LOGICAL ACB'FOPTIONS = ACB+6;                                        07740000
   LOGICAL ACB'AOPTIONS = ACB+7;                                        07742000
   INTEGER ACB'RSIZE    = ACB+8;                                        07744000
   INTEGER ACB'BSIZE    = ACB+9;                                        07746000
   LOGICAL                                                     <<04578>>07748000
      ACB'RSIZE'L       = ACB'RSIZE,                           <<04578>>07750000
      ACB'BSIZE'L       = ACB'BSIZE;                           <<04578>>07752000
   LOGICAL ACB'CTL      = ACB+11;                                       07754000
   LOGICAL ACB'LSTATE   = ACB+12;                                       07756000
   LOGICAL ACB'MODW     = ACB+13;                                       07758000
   INTEGER ACB'ERROR    = ACB+14;                                       07760000
   INTEGER ACB'TLOG     = ACB+15;                                       07762000
   DOUBLE ACB'FPTR      = ACB+16;                                       07764000
   LOGICAL ACB'FPLOW    = ACB+17;                                       07766000
   DOUBLE ACB'BLK       = ACB+18;                                       07768000
   DOUBLE ACB'RTFRCT    = ACB+20;                                       07770000
   DOUBLE ACB'BTFRCT    = ACB+22;                                       07772000
   DOUBLE ACB'HIBLK     = ACB+24;                                       07774000
   INTEGER ACB'FCB      = ACB+26;                                       07776000
   LOGICAL ACB'STATW    = ACB+29;                                       07778000
   LOGICAL ACB'GSTW     = ACB+30;                                       07780000
   INTEGER ACB'BUFX     = ACB+31;                                       07782000
   INTEGER ACB'BUFUSED  = ACB+32;                                       07784000
   INTEGER ACB'AMLD     = ACB+38;                                       07786000
   LOGICAL ACB'SPFL     = ACB+39;                                       07788000
   INTEGER ACB'SPTYRC   = ACB+40;                                       07790000
   INTEGER ACB'SPFOPT   = ACB+41;                                       07792000
   INTEGER ACB'SPAOPT   = ACB+42;                                       07794000
   INTEGER ACB'SPXDDX   = ACB+43;                                       07796000
   INTEGER ACB'NOWAITLDEV= ACB+27;                                      07798000
   DOUBLE  ACB'NOWAITDA = ACB+44;                                       07800000
   DOUBLE ACB'X1X2      = ACB+46;                                       07802000
                                                                        07804000
   INTEGER BUFDST       = ACB+48;    << DST of PACB buffers >>          07806000
   INTEGER PACBOFST     = ACB+49;                                       07808000
   INTEGER DBOFST       = ACB+53;                                       07810000
   INTEGER DSTX         = ACB+56;    << DST of user's buffer >>         07812000
                                                               <<04592>>07814000
DEFINE                                                         <<04592>>07816000
   FREADDIR'MODE        = (MODE  =   0)#,                      <<04592>>07818000
   FWRITEDIR'MODE       = (MODE  =   1)#,                      <<04592>>07820000
   FCONTROL'MODE        = (MODES =   2)#,                      <<04592>>07822000
   FOPEN'MODE           = (MODES =   3)#,                      <<04592>>07824000
   FCLOSE'MODE          = (MODES =   4)#,                      <<04592>>07826000
   FREADBACKWARD'MODE   = (MODE.(13:3) = 6)#,                  <<04700>>07828000
   FREADSEEK'MODE       = (MODE  = %10)#,                      <<04592>>07830000
   WRITE'EOF'MODE       = (MODE  = %11)#,                      <<04592>>07832000
   FREAD'MODE           = (MODE  = %20)#,                      <<04592>>07834000
   FWRITE'MODE          = (MODE  = %21)#,                      <<04592>>07836000
   RIO'DELETE'MODE      = (MODE  = %40)#,                      <<04592>>07838000
   RIO'ACTIVE'MODE      = (MODE  = %50)#;                      <<04592>>07840000
                                                                        07842000
DEFINE READ = NOT MODE#,                                                07844000
   DIRECT'ACCESS = FREADDIR'MODE OR FWRITEDIR'MODE#,           <<04590>>07846000
   ACB'NUMBUF    =ACB'BUFX.(12:4)#,                            <<HM.00>>07848000
   ACB'CIROVERFLOW=ACB'MODW.(7:1)#,                            <<01943>>07850000
   BLK'FLAGS     =BLK'FLAGW.( 8:8)#,                           <<04625>>07852000
   BLK'UNALLOCEXT=BLK'FLAGW.(10:1)#,                           <<04625>>07854000
   BLK'REVERSE   =BLK'FLAGW.(11:1)#,                           <<04590>>07856000
   BLK'DONTWAIT  =BLK'FLAGW.(12:1)#,                           <<04590>>07858000
   BLK'IOOUT     =BLK'FLAGW.(13:1)#,                                    07860000
   BLK'IOCOMP    =BLK'FLAGW.(14:2)#,                                    07862000
   BLK'DIRTY     =BLK'FLAGW.(14:1)#,                                    07864000
   BLK'IOPEND    =BLK'FLAGW.(15:1)#,                                    07866000
   EMPTY         = -1D#,                                       <<04566>>07868000
    NOWAIT = (INTEGER(MODE.(10:3)) > %2)#,                     <<00.SD>>07870000
    NOWAITCOMP = (MODE.(10:3) = %4)#;                          <<00.SD>>07872000
                                                                        07874000
<< Local variables [Q+]. T1 thru T6 must be first & contiguous. >>      07876000
                                                                        07878000
   INTEGER T1, T2, T3, T4, T5, T6;                                      07880000
      LOGICAL LT1 = T1;                                                 07882000
      LOGICAL LT2 = T2;                                                 07884000
      DOUBLE DT1T2 = T1;                                                07886000
      DOUBLE DT3T4 = T3;                                                07888000
      DOUBLE DT4T5 = T4;                                                07890000
      DOUBLE DT5T6 = T5;                                                07892000
      DOUBLE OLD'EOF = DT1T2,    << EOF's for FSET'EOF      >> <<04562>>07894000
             NEW'EOF = DT3T4;                                  <<04562>>07896000
                                                                        07898000
EQUATE BLKOFFSET = 6;    << @BLKIOQX - @T1 >>                           07900000
EQUATE MAX'WORD'TCOUNT = 16*1024-1; <<16K-1 max word TCOUNT >> <<04558>>07902000
                                                                        07904000
   << Current block header image [buffered access] >>                   07906000
                                                                        07908000
   INTEGER BLK'IOQX;                                                    07910000
   LOGICAL BLK'FLAGW;                                                   07912000
   DOUBLE BLK'IOCB, BLK'BLOCK, BLK'DADDR;                               07914000
   DOUBLE BLK'EXTBASE;   << extent base of current block >>    <<04653>>07916000
   LOGICAL BLK'EXTSIZE;  << extent size in sectors       >>    <<04653>>07918000
   LOGICAL BLK'DUMMY;    << * * * NOT CURRENTLY USED * * >>    <<04653>>07920000
      INTEGER BLK'LSTAT = BLK'IOCB;                                     07922000
      INTEGER BLK'TLOG  = BLK'IOCB+1;                                   07924000
                                                               <<04566>>07926000
      LOGICAL             << 16 bits log. for buffer algor. >> <<04566>>07928000
         BLK'IN,          << Block is already in a buffer?  >> <<04566>>07930000
      BUF'EMPTY;          << Used to find an empty buffer.  >> <<04566>>07932000
                                                                        07934000
   INTEGER BC;                                                          07936000
   INTEGER WC;                                                          07938000
   LOGICAL                                                     <<04557>>07940000
      STX          , << Sectors available in current extent.>> <<04557>>07942000
      SECTS'TRNSFRD; << Sectors trnsfrd, NOBUF, curr. xfer. >> <<04557>>07944000
   DOUBLE                                                      <<04557>>07946000
      BLKS'TRNSFRD,  << Blocks trnsfrd. NOBUF, curr. xfer.  >> <<04557>>07948000
      RECS'TRNSFRD,  << Records trnsfrd, NOBUF, curr xfer.  >> <<04557>>07950000
      BLKS'FILE    , << Number of blocks left in the file.  >> <<04557>>07952000
      RECS'FILE    , <<  "  "   " records "   "   "    "    >> <<04557>>07954000
      WORDS'FILE   ; <<  "  "   " words   "   "   "    "    >> <<04557>>07956000
   INTEGER                                                     <<04557>>07958000
      SECTS'TO'FILL,         << Fill sect. of short write.  >> <<04578>>07960000
      CORRECTION,            << Correction term for TLOG/CNT>> <<04578>>07962000
      RECS'FILE'0 = RECS'FILE;  << Number recs > int. word? >> <<04557>>07964000
                                                               <<04557>>07966000
   INTEGER WTT;           << words to xfer, this I/O >>                 07968000
   INTEGER CTT;           << chars to xfer, this I/O >>                 07970000
   LOGICAL                                                     <<04578>>07972000
      WTT'L = WTT,                                             <<04578>>07974000
      CTT'L = CTT;                                             <<04578>>07976000
   LOGICAL SPEC;          << CHKVARBLK subr variables >>                07978000
   INTEGER                                                     <<04578>>07980000
      VAR'WORD'CNT,       << Used for CHKVARBLK.            >> <<04578>>07982000
      SPEC'VAR'CNT,       << Second word of spec. var. rec. >> <<04578>>07984000
      VAR'REC'SIZE,                                            <<04578>>07986000
      NUM'VAR'BLKS;                                            <<04578>>07988000
   LOGICAL                                                     <<04578>>07990000
      BAD'VAR'BLK,                                             <<04578>>07992000
      END'OF'BLK,                                              <<04578>>07994000
      LOC,                   << General purpose buff. loc.  >> <<04578>>07996000
      CHARS'TO'FILL,         << Short block read, fill in.  >> <<04578>>07998000
      CLEARTYPE;             << Clear blk with 0's or blanks>> <<04578>>08000000
   DOUBLE                                                      <<04578>>08002000
      NUM'VAR'RECS,                                            <<04578>>08004000
      NMAX;           << # of records left in the file.     >> <<04578>>08006000
DEFINE INFINITE = 1000000000D#;                                         08008000
   INTEGER CHAR'TRNSFRD;  << Characters transfered,this I/O.>> <<04578>>08010000
   LOGICAL CHAR'TRNSFRD'L = CHAR'TRNSFRD;                      <<04578>>08012000
   BYTE POINTER BTARGET;  << target byte pointer >>                     08014000
                                                                        08016000
   << Misc. file parameters >>                                          08018000
                                                                        08020000
   DOUBLE EXTBASE;    << current disc extent sector addr >>    <<04653>>08022000
   LOGICAL EXTSIZE;   << current disc extent size        >>    <<04653>>08024000
   DOUBLE FCEOF;          << EOF record nr. >>                          08026000
   INTEGER                                                     <<04567>>08028000
      RSIZE,              << Record size in words.          >> <<04567>>08030000
      FCONV'ERROR;        << FCONV'BLK error number.        >> <<04567>>08032000
   LOGICAL MR;            << multi-record access flag >>                08034000
   LOGICAL FIRST'WRITE;                                        <<04578>>08036000
   LOGICAL NEWEOF;        << EOF advanced? - disk only >>               08038000
   INTEGER EOFDELTA := 0;                                               08040000
   LOGICAL SPOOLF;    << -1 if spooler access [NOBUF]; +1 if user       08042000
                       accessing spoofle [buffered]>>                   08044000
   INTEGER NONDATARECORDS; << Msg files, # open/close recs>>   <<HM.00>>08046000
                                                                        08048000
   DOUBLE T1ADR;         << DST-rel addr of T1 vars >>                  08050000
      INTEGER STKDST=T1ADR;                                             08052000
      INTEGER Q'1'A =T1ADR+1;     << will be %100 > ACBOFST. >>         08054000
                                                                        08056000
   << ATTACHIO variables >>                                             08058000
                                                                        08060000
   INTEGER LDEV;          << LDEV of block >>                           08062000
   DOUBLE                                                      <<04566>>08064000
      IO'STATUS,          << Return status from ATTACHIO.   >> <<04566>>08066000
      DISKADR;            << Sector number of block.        >> <<04566>>08068000
   INTEGER P1 = DISKADR;  << sector nr. - first half >>                 08070000
   INTEGER P2 = DISKADR+1;  << sector nr. - second half >>              08072000
   INTEGER                                                     <<04578>>08074000
      ATTIO'COUNT,                                             <<04578>>08076000
      NOWAIT'IOQX   = IO'STATUS   , << No-wait I/O word 1   >> <<04578>>08078000
      NOWAIT'STATUS = IO'STATUS +1, << No-wait I/O word 2   >> <<04578>>08080000
      WAITIO'STATUS = IO'STATUS   , << Wait for I/O word 1  >> <<04578>>08082000
      WAITIO'TLOG   = IO'STATUS +1; << Wait for I/O word 2  >> <<04578>>08084000
   DEFINE                                                      <<04578>>08086000
      ERR'STAT     = WAITIO'STATUS.(8:8)#,                     <<04578>>08088000
      NOWAIT'COMP  = ATTIOFLAGS.(13:3)=0#,                     <<04578>>08090000
      WAITIO'COMP  = ATTIOFLAGS.(13:3)=1#;                     <<04578>>08092000
   LOGICAL                                                     <<04645>>08094000
      FLAGS,           << Used for ATTIOFLAGS for caching.  >> <<04653>>08096000
       RSIZE'BRU,          << RSIZE, Bytes, Rounded Up.     >> <<04644>>08098000
      ATTIOFLAGS,      << Last parameter to ATTACHIO.       >> <<04645>>08100000
      SHORT'BLOCK;     << TRUE if short block read MR.      >> <<04645>>08102000
                                                                        08104000
   << ACB buffer variables >>                                           08106000
                                                                        08108000
   INTEGER BUFDISP;    << PACB DST-rel buff addr >>                     08110000
                                                                        08112000
   INTEGER I,         << Block buffer in use >>                         08114000
           NUM'BUFS;  << number of buffers >>                  <<04566>>08116000
   INTEGER                                                     <<04578>>08118000
      BC'TRAIL'FILL   ,  << Trailing fill chars., spoolfle. >> <<04578>>08120000
      REC'OVERHEAD    ,  << Special spoolfile rec. overhead.>> <<04578>>08122000
      MODES           ,  << Spoolfile mode.                 >> <<04578>>08124000
      BLK'OVERHEAD    ,  << Special spoolfile blk. overhead.>> <<04578>>08126000
      DATASIZE        ;  << Words of data in block.         >> <<04578>>08128000
                                                                        08130000
   << Misc. file parameters >>                                          08132000
                                                                        08134000
   INTEGER BC'DATA'REC; << Data portion of var/undef.       >> <<04578>>08136000
   LOGICAL IMBED;     << 1 if imbed carriage control >>                 08138000
   INTEGER CCTL=IMBED;<< "  "    "      "       "    >>        <<04560>>08140000
   INTEGER FILL;      << fill word >>                                   08142000
   DOUBLE DBLKFACT;                                                     08144000
      INTEGER BLKFACT = DBLKFACT+1;                                     08146000
                                                                        08148000
   << Requested block variables >>                                      08150000
                                                                        08152000
   DOUBLE BLOCK;     << Block number >>                                 08154000
   INTEGER REC'PNTR; << Record position within block (words)>> <<04578>>08156000
   INTEGER RXB;      << record index in block, for RIO >>               08158000
INTEGER XI;              << ** for bug trap ** >>                       08160000
                                                                        08162000
EQUATE    << Misc. equates go here.                         >> <<04566>>08164000
   UNALLOC'EXT  =  -1,   << Return from FCONV'BLK.          >> <<04567>>08166000
   STUB'IOQX    =  -1,   << Stub IOQX for unalloc. extents. >> <<04567>>08168000
   NOT'FOUND    =  -1;   << Needed buffer has not been fnd. >> <<04566>>08170000
$PAGE                                                          <<04557>>08172000
<<  ****  Begin subroutines  ****  >>                                   08174000
                                                                        08176000
   SUBROUTINE ERREXIT(ERRNUM);                                          08178000
   VALUE ERRNUM; INTEGER ERRNUM;                                        08180000
      BEGIN                                                             08182000
      DEL;          << discard return address >>                        08184000
      ACB'ERROR := TOS;                                                 08186000
      ACB'STATUS := 0;     << force CCL >>                     <<01759>>08188000
      GO EXIT                                                           08190000
      END;                                                              08192000
                                                                        08194000
<< This subroutine sets the ATTACHIO flags for NOBUF I/O >>    <<04653>>08196000
SUBROUTINE FIX'ATTACHIO'FLAGS;                                 <<04653>>08198000
BEGIN                                                          <<04653>>08200000
                                                               <<04653>>08202000
ATTIOFLAGS := UFLAGS CAT NOT NOWAIT (15:15:1);                 <<04653>>08204000
<< Determine IF this is a KSAM, IMAGE, seq or direct file >>   <<04653>>08206000
IF FREAD'MODE OR FWRITE'MODE THEN                              <<04653>>08208000
  ATTIOFLAGS.FLG'CNTL := NOBUF'SEQ << FREAD or FWRITE >>       <<04653>>08210000
ELSE                                                           <<04653>>08212000
  BEGIN  << We are dealing with a direct file of some sort >>  <<04653>>08214000
  ATTIOFLAGS.FLG'CNTL := NOBUF'DIR;                            <<04653>>08216000
  IF DSTX <> 0 THEN  << I/O is not to user's stack         >>  <<04653>>08218000
    BEGIN                                                      <<04653>>08220000
    IF DADB0 = "KSAM" THEN                                     <<04653>>08222000
      ATTIOFLAGS.FLG'CNTL := NOBUF'KSAM ELSE                   <<04653>>08224000
    IF DADB0 = "IMAG" THEN                                     <<04653>>08226000
      ATTIOFLAGS.FLG'CNTL := NOBUF'IMAGE;                      <<04653>>08228000
    END;                                                       <<04653>>08230000
  END;  << of dealing with direct files >>                     <<04653>>08232000
END;  << of subroutine FIX'ATTACHIO'FLAGS >>                   <<04653>>08234000
                                                               <<04653>>08236000
   SUBROUTINE GET2WORDS;                                                08238000
<< Fetches two words at R and R+1 from ACB buffer to T1 and T2. >>      08240000
      BEGIN                                                             08242000
      TOS := T1ADR;                                                     08244000
      TOS := BUFDST;                                                    08246000
      TOS := REC'PNTR + BUFDISP;                               <<04578>>08248000
      TOS := 2;                                                         08250000
      MOVE'DS'5;                                                        08252000
      END;                                                              08254000
                                                                        08256000
   SUBROUTINE GETBLKPARMS;                                              08258000
<< Copies block buffer header words for block I from PACB               08260000
   to Q+ local storage.  >>                                             08262000
      BEGIN                                                             08264000
      XI := I;            << ** set bug trap  ** >>                     08266000
      TOS := T1ADR;                                                     08268000
      TOS := TOS+BLKOFFSET;    << @ block header buffer >>              08270000
      TOS := BUFDST;                                                    08272000
      TOS := PACBOFST+SIZEACB+I*(BLKBUFDISP+ACB'BSIZE);                 08274000
      TOS := BLKBUFDISP;     << nr. words in header >>                  08276000
      MOVE'DS'1;                                                        08278000
      BUFDISP := TOS;     << ACB buffer address >>                      08280000
      ASMB(DDEL,DEL);                                                   08282000
      END;                                                              08284000
                                                                        08286000
   SUBROUTINE PUTBLKPARMS;                                              08288000
<< Posts local storage image for block I to block buffer header         08290000
   in PACB.   >>                                                        08292000
      BEGIN                                                             08294000
      IF XI <> I THEN FTROUBLE(51);  << ** caught bug ** >>             08296000
      TOS := BUFDST;                                                    08298000
      TOS := PACBOFST+SIZEACB+I*(BLKBUFDISP+ACB'BSIZE);                 08300000
      TOS := T1ADR;                                                     08302000
      TOS := TOS+BLKOFFSET;                                             08304000
      TOS := BLKBUFDISP;     << nr. words in header >>                  08306000
      MOVE'DS'5;                                                        08308000
      END;                                                              08310000
$PAGE                                                          <<04557>>08312000
   DOUBLE SUBROUTINE FSET'EOF(EOFREC);                                  08314000
   VALUE EOFREC; DOUBLE EOFREC;                                <<04562>>08316000
                                                               <<04562>>08318000
   <<*******************************************************>> <<04562>>08320000
   << Advances EOF in the FCB if needed.  Update EOF on ev- >> <<04562>>08322000
   << ery write to a variable length file.  Used to obtain  >> <<04562>>08324000
   << EOF pointer on a read also.  For foriegn discs, return>> <<04562>>08326000
   << size of the disc.                                     >> <<04562>>08328000
   <<*******************************************************>> <<04562>>08330000
                                                               <<04562>>08332000
   BEGIN                                                       <<04562>>08334000
   NEW'EOF := EOFREC;                                          <<04562>>08336000
   IF ACB'FCB = 0 THEN                                         <<04562>>08338000
      OLD'EOF := DISCSIZE(LDEV)                                <<04562>>08340000
   ELSE                                                        <<04562>>08342000
      BEGIN                                                    <<04562>>08344000
      OLD'EOF := GETFCB'INFO(ACB'FCB,XEOF);                    <<04562>>08346000
      IF NEW'EOF > OLD'EOF OR ACB'VARIABLE AND NOT READ THEN   <<04562>>08348000
         BEGIN                                                 <<04562>>08350000
         PUTFCB'INFO(ACB'FCB,XEOF,NEW'EOF);   << Post EOF   >> <<04562>>08352000
                                                               <<04562>>08354000
         <<*************************************************>> <<04562>>08356000
         << For variable length files, store the current    >> <<04562>>08358000
         << block number in FCBEND.                         >> <<04562>>08360000
         <<*************************************************>> <<04562>>08362000
                                                               <<04562>>08364000
         IF ACB'VARIABLE                                       <<04562>>08366000
            THEN PUTFCB'INFO(ACB'FCB,XEND,ACB'BLK);            <<04562>>08368000
         END;                                                  <<04562>>08370000
      END;                                                     <<04562>>08372000
   FSET'EOF := OLD'EOF; << Return value for READ.           >> <<04562>>08374000
   END;                                                        <<04562>>08376000
$PAGE                                                          <<04557>>08378000
   LOGICAL SUBROUTINE GETARTWORD;                                       08380000
      BEGIN                                                             08382000
      TOS := T1ADR;                                                     08384000
      TOS := BUFDST;                                                    08386000
      TOS := BUFDISP+DATASIZE+RXB/16;                                   08388000
      TOS := 1;                                                         08390000
      MOVE'DS'5;            << fetch bitmap word to T1 >>               08392000
      X := RXB MOD 16;      << return bit index in X >>                 08394000
      GETARTWORD := T1;                                                 08396000
      END;                                                              08398000
                                                                        08400000
   SUBROUTINE PUTARTWORD(VAL);                                          08402000
   VALUE VAL; INTEGER VAL;                                              08404000
      BEGIN                                                             08406000
      T1 := VAL;       << bitmap to be stored >>                        08408000
      TOS := BUFDST;                                                    08410000
      TOS := BUFDISP+DATASIZE+RXB/16;                                   08412000
      TOS := T1ADR;                                                     08414000
      TOS := 1;                                                         08416000
      MOVE'DS'5;       << move from T1 to ART area >>                   08418000
      BLK'DIRTY := 1;                                                   08420000
      END;                                                              08422000
$PAGE                                                          <<04567>>08424000
SUBROUTINE CLEAR'CURR'BUF;                                     <<04567>>08426000
                                                               <<04567>>08428000
<<**********************************************************>> <<04567>>08430000
<< Clear the current buffer with fill characters.  This is  >> <<04567>>08432000
<< used when reading from an un-allocated extent. RIO files >> <<04567>>08434000
<< always fill w / 0's so that the ART shows no active recs.>> <<04567>>08436000
<<**********************************************************>> <<04567>>08438000
                                                               <<04567>>08440000
BEGIN                                                          <<04567>>08442000
                                                               <<04567>>08444000
IF ACB'RIO                                                     <<04567>>08446000
   THEN T1 := 0                                                <<04567>>08448000
   ELSE T1 := FILL;                                            <<04567>>08450000
TOS := BUFDST;           << DST # of buffer.                >> <<04567>>08452000
TOS := BUFDISP;          << DST offset to current buffer.   >> <<04567>>08454000
TOS := T1ADR;            << DST and offset of fill char.    >> <<04567>>08456000
TOS := 1;                                                      <<04567>>08458000
MOVE'DS'3;               << Stuff fill in 1st. word.        >> <<04567>>08460000
TOS := BUFDST;                                                 <<04567>>08462000
TOS := BUFDISP;          << Propigate from fill on to end.  >> <<04567>>08464000
TOS := ACB'BSIZE - 1;                                          <<04567>>08466000
MOVE'DS'5;               << Propigate that there fill!      >> <<04567>>08468000
                                                               <<04567>>08470000
END;                                                           <<04567>>08472000
                                                               <<04567>>08474000
                                                               <<04567>>08476000
SUBROUTINE STUFF'IOQX(IOQX);                                   <<04567>>08478000
VALUE IOQX;INTEGER IOQX;                                       <<04567>>08480000
                                                               <<04567>>08482000
<<**********************************************************>> <<04567>>08484000
<< Stuffs the IOQX into the correct word of the AFT.  Used  >> <<04567>>08486000
<< for no-wait, unbuffered I/O.                             >> <<04567>>08488000
<<**********************************************************>> <<04567>>08490000
                                                               <<04567>>08492000
BEGIN                                                          <<04567>>08494000
                                                               <<04567>>08496000
PUSH(Q,DL);                                                    <<04567>>08498000
ASMB(XCH,SUB);                        << TOS := DL - Q;     >> <<04567>>08500000
X := TOS - (ACB'FNUM + 1) * AFTENTRY; << X := @AFT0(N);     >> <<04567>>08502000
AQPL3(X) := IOQX;        << Save IOQX in AFT for IOWAIT.    >> <<04567>>08504000
                                                               <<04567>>08506000
END;                                                           <<04567>>08508000
$PAGE                                                          <<04567>>08510000
SUBROUTINE CLEAR'NOBUFF;                                       <<04567>>08512000
                                                               <<04567>>08514000
<<**********************************************************>> <<04567>>08516000
<< Clear the users buffer in the no-buff case with fill     >> <<04567>>08518000
<< characters.  This is used when reading from an un-allo-  >> <<04567>>08520000
<< cated extent no-buff.  FCONV'BLK does not allocate the   >> <<04567>>08522000
<< extent, thus saving much time and disc space!  RIO files >> <<04567>>08524000
<< always fill w / 0's so that the ART shows no active recs.>> <<04567>>08526000
<<**********************************************************>> <<04567>>08528000
                                                               <<04567>>08530000
BEGIN                                                          <<04567>>08532000
                                                               <<04567>>08534000
IF ACB'RIO                                                     <<04567>>08536000
   THEN T1 := 0                                                <<04567>>08538000
   ELSE T1 := FILL;                                            <<04567>>08540000
                                                               <<04567>>08542000
IF TCOUNT < 0 THEN                                             <<04567>>08544000
   BEGIN                   << Byte count, use MOVE bytes.   >> <<04567>>08546000
   @BTARGET := @TARGET * 2;                                    <<04567>>08548000
   BTARGET(0) := BYTE(T1);                                     <<04567>>08550000
   MOVE BTARGET(1) := BTARGET(0), (CTT-1);                     <<04567>>08552000
   CHAR'TRNSFRD := -CTT;   << Negative byte TLOG.           >> <<04578>>08554000
   END                                                         <<04567>>08556000
ELSE                                                           <<04567>>08558000
   BEGIN                   << Word count, use MOVE words.   >> <<04567>>08560000
   TARGET(0) := T1;                                            <<04567>>08562000
   MOVE TARGET(1) := TARGET(0), (WTT-1);                       <<04567>>08564000
   CHAR'TRNSFRD := WTT;    << Positive word TLOG.           >> <<04578>>08566000
   END;                                                        <<04567>>08568000
                                                               <<04567>>08570000
<<**********************************************************>> <<04567>>08572000
<< Now, if we are going no-wait I/O, we must kludge the     >> <<04567>>08574000
<< IOQX in the AFT.  We place a negative number in IOQX.    >> <<04567>>08576000
<< IOWAIT will recognize this as a stub and process it as   >> <<04567>>08578000
<< successful when called by the user at a later time.      >> <<04567>>08580000
<<**********************************************************>> <<04567>>08582000
                                                               <<04567>>08584000
IF NOWAIT THEN                                                 <<04567>>08586000
   BEGIN                                                       <<04567>>08588000
   ACB'TLOG := CHAR'TRNSFRD;<< Save TLOG for later.         >> <<04578>>08590000
   STUFF'IOQX(STUB'IOQX);  << Place -1 kludge in AFT.       >> <<04567>>08592000
   ACB'NOWAITMODE := 0;    << No-wait READ.                 >> <<04567>>08594000
   GO SETX;                << Claim successful read.        >> <<04567>>08596000
   END;                                                        <<04567>>08598000
                                                               <<04567>>08600000
END;                                                           <<04567>>08602000
$PAGE                                                          <<04557>>08604000
LOGICAL SUBROUTINE CHKVARBLK;                                  <<04578>>08606000
                                                               <<04578>>08608000
<<**********************************************************>> <<04578>>08610000
<< On NOBUF read or write, validate variable record struc-  >> <<04578>>08612000
<< ture within block(s) and count records.                  >> <<04578>>08614000
<<   Output variables:                                      >> <<04578>>08616000
<<      CHKVARBLK -  TRUE of a bad variable structure found.>> <<04578>>08618000
<<                   FALSE if A-OK.                         >> <<04578>>08620000
<<      NUM'VAR'RECS - The number of records read this xfer.>> <<04578>>08622000
<<      VAR'WORD'CNT - The number of words read this xfer,  >> <<04578>>08624000
<<                     this will be rounded up to the near- >> <<04578>>08626000
<<                     est block multiple.                  >> <<04578>>08628000
<<**********************************************************>> <<04578>>08630000
                                                               <<04578>>08632000
BEGIN                                                          <<04578>>08634000
NUM'VAR'RECS := 0D;                                            <<04578>>08636000
NUM'VAR'BLKS := 0;                                             <<04578>>08638000
VAR'WORD'CNT := 0;                                             <<04578>>08640000
END'OF'BLK := BAD'VAR'BLK := FALSE;                            <<04578>>08642000
                                                               <<04578>>08644000
IF INTEGER(SPEC) < 0 THEN                                      <<04578>>08646000
   IF READ THEN                                                <<04578>>08648000
      BEGIN    << Spoofle FREAD, get record number from blk.>> <<04578>>08650000
      TOS := TARGET(ACB'BSIZE -2);  << High order word.     >> <<04578>>08652000
      TOS := TARGET(ACB'BSIZE -1);  << Low  order word.     >> <<04578>>08654000
      ACB'FPTR := TOS;              << Set file pointer.    >> <<04578>>08656000
      END                                                      <<04578>>08658000
   ELSE                                                        <<04578>>08660000
      BEGIN    << Spoofle FWRITE, put record into block.    >> <<04578>>08662000
      TOS := ACB'FPTR;                                         <<04578>>08664000
      TARGET(ACB'BSIZE - 1) := TOS; << Low order word.      >> <<04578>>08666000
      TARGET(ACB'BSIZE - 2) := TOS; << High order word.     >> <<04578>>08668000
      END;                                                     <<04578>>08670000
                                                               <<04578>>08672000
WHILE NUM'VAR'RECS < NMAX AND VAR'WORD'CNT < WTT AND           <<04578>>08674000
      NOT BAD'VAR'BLK DO                                       <<04578>>08676000
   BEGIN                                                       <<04578>>08678000
   NUM'VAR'BLKS := NUM'VAR'BLKS + 1;                           <<04578>>08680000
   DO BEGIN                                                    <<04578>>08682000
      VAR'REC'SIZE := TARGET(VAR'WORD'CNT);  << Byte count. >> <<04578>>08684000
      IF VAR'REC'SIZE = -1                                     <<04578>>08686000
         THEN END'OF'BLK := TRUE      << End of block, OK   >> <<04578>>08688000
      ELSE IF VAR'REC'SIZE < 0 OR VAR'REC'SIZE > ACB'RSIZE     <<04578>>08690000
         THEN BAD'VAR'BLK := TRUE     << Invalid byte count!>> <<04578>>08692000
      ELSE IF SPEC AND                                         <<04578>>08694000
              VAR'REC'SIZE > INT(TARGET(VAR'WORD'CNT+1)) + 8   <<04578>>08696000
         THEN BAD'VAR'BLK := TRUE  << Byte cnts don't jive. >> <<04578>>08698000
      ELSE                                                     <<04578>>08700000
         BEGIN                                                 <<04578>>08702000
         << # of words in record, including count word.     >> <<04578>>08704000
         VAR'REC'SIZE := ((VAR'REC'SIZE+1)/2)+1;               <<04578>>08706000
         VAR'WORD'CNT := VAR'WORD'CNT + VAR'REC'SIZE;          <<04578>>08708000
         << Check for overflow.  User must read a valid blk.>> <<04578>>08710000
         IF VAR'WORD'CNT > NUM'VAR'BLKS * ACB'BSIZE OR         <<04578>>08712000
            VAR'WORD'CNT + 1 > WTT                             <<04578>>08714000
            THEN BAD'VAR'BLK := TRUE;  <<    Overflow       >> <<04578>>08716000
         NUM'VAR'RECS := NUM'VAR'RECS + 1D;                    <<04578>>08718000
         END;                                                  <<04578>>08720000
      END                                                      <<04578>>08722000
   UNTIL BAD'VAR'BLK OR END'OF'BLK;                            <<04578>>08724000
                                                               <<04578>>08726000
   << Now jump to the beginning of the next block .         >> <<04578>>08728000
   VAR'WORD'CNT := NUM'VAR'BLKS * ACB'BSIZE;                   <<04578>>08730000
   END;                                                        <<04578>>08732000
                                                               <<04578>>08734000
CHKVARBLK := BAD'VAR'BLK;                                      <<04578>>08736000
END;                                                           <<04578>>08738000
$PAGE                                                          <<04557>>08740000
                                                                        08742000
   LOGICAL SUBROUTINE WAYT (REPORT);                                    08744000
                                                               <<04590>>08746000
   <<*******************************************************>> <<04590>>08748000
   << Waits for completion of the I/O request against the   >> <<04590>>08750000
   << current buffer, as specified by the BUFDISP pointer.  >> <<04590>>08752000
   << If the I/O completes unsuccessfully, it is optionally >> <<04590>>08754000
   << indicated by the result.                              >> <<04590>>08756000
   <<                                                       >> <<04590>>08758000
   <<   Input parameters:                                   >> <<04590>>08760000
   <<       REPORT - Report I/O error flag                  >> <<04590>>08762000
   <<          FALSE - Ignore all I/O errors                >> <<04590>>08764000
   <<          TRUE - Report all errors except End-of-Tape  >> <<04590>>08766000
   <<                 and recovered tape parity I/O errors. >> <<04590>>08768000
   <<                                                       >> <<04590>>08770000
   <<   Output value:                                       >> <<04590>>08772000
   <<       WAYT - I/O error flag                           >> <<04590>>08774000
   <<          FALSE - OK                                   >> <<04590>>08776000
   <<          TRUE - reportable I/O error                  >> <<04590>>08778000
   <<*******************************************************>> <<04590>>08780000
                                                               <<04590>>08782000
      VALUE REPORT;                                                     08784000
      LOGICAL REPORT;                                                   08786000
      BEGIN                                                             08788000
      IF NOWAIT'COMP AND BLK'IOQX <> 0 THEN                    <<04578>>08790000
         BEGIN          << I/O pending >>                               08792000
         IO'STATUS := WAITFORIO(BLK'IOQX);                     <<04578>>08794000
$  IF X1 = ON                                                           08796000
         IF <> THEN FTROUBLE(479);  << error >>                         08798000
$  IF                                                                   08800000
         BLK'IOCB := IO'STATUS;  << Save T-log and status >>   <<04578>>08802000
         BLK'IOQX := 0          << Clear IOQX >>                        08804000
         END;                                                           08806000
      BLK'IOCOMP := 0;      << Buffer clean and no I/O going >>         08808000
      ACB'STATUS := BLK'LSTAT;  << Report I/O status >>                 08810000
      IF ACB'STATUS <> 1 AND REPORT THEN                                08812000
         BEGIN                 << Error to report, maybe >>             08814000
         IF ACB'GSTATUS = 2 THEN                                        08816000
            BEGIN              << Hardware EOF. >>                      08818000
            ACB'EOFS := 3;                                              08820000
            ACB'EOF := 1;                                               08822000
            END;                                                        08824000
         ACB'ERROR := IOSTAT(ACB'STATUS);    << Convert error nr. >>    08826000
         IF ACB'ERROR <> EOT AND ACB'ERROR <> TAPERREC THEN    <<02072>>08828000
            BEGIN                                                       08830000
            WAYT := TRUE;     << Report error >>                        08832000
            RETURN                                                      08834000
            END                                                         08836000
         END;         << error to report, maybe >>                      08838000
                                                                        08840000
   << I/O has been completed. If reading, pad the block with fill       08842000
     characters if it was short. >>                                     08844000
                                                                        08846000
      IF NOT BLK'FLAGS.(13:1) AND BLK'TLOG < DATASIZE                   08848000
           AND ACB'FIXED THEN                                  <<00630>>08850000
         BEGIN     << Pad short block read. >>                 <<00630>>08852000
         T1 := FILL;                                                    08854000
         TOS := BUFDST;                                                 08856000
         TOS := BUFDISP+BLK'TLOG;    << @End of user buffer >>          08858000
         TOS := T1ADR;                                                  08860000
         TOS := 1;                                                      08862000
         MOVE'DS'3;     << stuff fill in first word >>                  08864000
         ASMB(DDUP, DECA);                                              08866000
         TOS := DATASIZE-BLK'TLOG-1;                                    08868000
         MOVE'DS'5;     << propagate fill >>                            08870000
         END;                                                           08872000
      ACB'BTFRCT := ACB'BTFRCT+1D;  << bump block transfer count >>     08874000
      PUTBLKPARMS;                                             <<04591>>08876000
      END;        << of subroutine WAYT >>                              08878000
$PAGE                                                          <<04590>>08882000
LOGICAL SUBROUTINE DONT'WAYT;                                  <<04590>>08884000
                                                               <<04590>>08886000
<<**********************************************************>> <<04590>>08888000
<< Check if the I/O request against the current buffer being>> <<04590>>08890000
<< investigated has completed.  This is done for all buffers>> <<04590>>08892000
<< with I/O pending when first entering IOMOVE on buffered  >> <<04590>>08894000
<< reads and writes to free valuable DRQ entries.  This is  >> <<04590>>08896000
<< done for disk files only.                                >> <<04590>>08898000
<<**********************************************************>> <<04590>>08900000
                                                               <<04590>>08902000
BEGIN                                                          <<04590>>08904000
DONT'WAYT := FALSE;           << Assume no error to report. >> <<04590>>08906000
IF BLK'IOQX <> 0 THEN                                          <<04590>>08908000
   BEGIN                      << There is indeed I/O pending>> <<04590>>08910000
   IO'STATUS := IOSTATUS(BLK'IOQX);                            <<04590>>08912000
   IF = THEN                                                   <<04590>>08914000
      BEGIN                   << I/O completed, clean up    >> <<04590>>08916000
      BLK'IOCB := IO'STATUS;  << Save T-log and status.     >> <<04590>>08918000
      BLK'IOQX := 0;          << All done!                  >> <<04590>>08920000
      BLK'IOCOMP := 0;        << Clean buffer, no I/O pend. >> <<04590>>08922000
      BLK'DONTWAIT := 1;      << Indicate DONT'WAIT I/O.    >> <<04590>>08924000
                                                               <<04590>>08926000
      <<****************************************************>> <<04590>>08928000
      << If reading, pad the block with fill characters if  >> <<04590>>08930000
      << it was short.                                      >> <<04590>>08932000
      <<****************************************************>> <<04590>>08934000
                                                               <<04590>>08936000
      IF NOT BLK'IOOUT AND BLK'TLOG < DATASIZE AND             <<04590>>08938000
         ACB'FIXED THEN                                        <<04590>>08940000
         BEGIN                                                 <<04590>>08942000
         T1 := FILL;               << Fill with Fill.       >> <<04590>>08944000
         TOS := BUFDST;            << Buffer address.       >> <<04590>>08946000
         TOS := BUFDISP + BLK'TLOG;<< @END of read.         >> <<04590>>08948000
         TOS := T1ADR;             << Copy from T1.         >> <<04590>>08950000
         TOS := 1;                                             <<04590>>08952000
         MOVE'DS'3;                << Stuff fill word 1.    >> <<04590>>08954000
         TOS := BUFDST;            << Fill from 1 on.       >> <<04590>>08956000
         TOS := BUFDISP + BLK'TLOG;                            <<04590>>08958000
         TOS := DATASIZE - BLK'TLOG - 1;                       <<04590>>08960000
         MOVE'DS'5;                << Propigate fill char.  >> <<04590>>08962000
         END;                                                  <<04590>>08964000
                                                               <<04590>>08966000
      ACB'BTFRCT := ACB'BTFRCT + 1D; << Bump blk exfer cnt. >> <<04590>>08968000
      PUTBLKPARMS;                   << Write updated head  >> <<04590>>08970000
      END;                                                     <<04590>>08972000
   END;                                                        <<04590>>08974000
                                                               <<04590>>08976000
END;                                                           <<04590>>08978000
$PAGE                                                          <<04590>>08980000
   SUBROUTINE STARTREAD(BLKNUM);                                        08982000
   VALUE BLKNUM; DOUBLE BLKNUM;                                         08984000
      << Called to start reading the specified block into the           08986000
     current buffer, as defined by the BUFDISP pointer.  >>             08988000
                                                                        08990000
      BEGIN                                                             08992000
      FCONV'ERROR := 0;                                        <<04567>>08994000
      IF ACB'ACCCL = DIRACC THEN                                        08996000
         BEGIN     << Disk >>                                           08998000
         FCONV'BLK(BLKNUM,ACBMQ,0,0,0D,0D,0);                  <<04653>>09000000
         BLK'EXTSIZE := TOS;  << Save current extent size.  >> <<04653>>09002000
         BLK'EXTBASE := TOS;  << Save current extent base   >> <<04653>>09004000
         FCEOF := TOS;                                                  09006000
         DEL;          << STX >>                                        09008000
         FCONV'ERROR := TOS;     << Error nr. >>               <<04567>>09010000
         IF FCONV'ERROR > 0 THEN                               <<04567>>09012000
            BEGIN      << Some kind of error. >>                        09014000
            IF FCONV'ERROR <= 2 THEN                           <<04567>>09016000
               BEGIN   << Beyond EOF; don't read. >>                    09018000
               ASMB(DDEL,DEL);  << sector & LDEV >>                     09020000
               RETURN                                                   09022000
               END;                                                     09024000
            ACB'ERROR := FCONV'ERROR;   << Report error nr. >> <<04567>>09026000
            ACB'STATUS := 0;  << Clear I/O error nr. >>                 09028000
            GO PEXIT                                                    09030000
            END;       << some kind of error >>                         09032000
         LDEV := TOS;      << LDEV of requested record/block >>         09034000
         DISKADR := DS1;   << Sector number for ATTACHIO >>             09036000
         BS1 := LDEV;      << Logical device nr. >>                     09038000
         BLK'DADDR := TOS;  << Save in block header >>                  09040000
         END                                                            09042000
      ELSE                                                              09044000
         BEGIN      << Not disk >>                                      09046000
         IF ACB'DTYPE = MTAPE THEN SET'LPDT'BOT(LDEV,0);       <<02545>>09048000
         TOS := ACB'CTL&LSR(8);       << P1.(13:3) - EOF spec. >>       09050000
         TOS.(0:1) := ACB'INHIBCRLF;  << P1.(0:1) - inhibit CR/LF >>    09052000
         TOS := ACB'STOPCHAR&LSL(8);  << P2.(0:8) - stop character >>   09054000
         TOS.(12:1) := NOT ACB'ASCII; << ASCII/binary format >>         09056000
         P2 := TOS; P1 := TOS                                           09058000
         END;                                                           09060000
      BLK'BLOCK := BLKNUM;          << Block nr. >>                     09062000
      IF BLKNUM > ACB'HIBLK THEN ACB'HIBLK := BLKNUM;  << New high >>   09064000
      BLK'FLAGS := 1;          << Denote read in progress >>   <<04563>>09066000
                                                               <<04567>>09068000
      <<****************************************************>> <<04567>>09070000
      << If we are reading from an un-allocated extent,     >> <<04567>>09072000
      << clear the buffer and return.  FCONV'BLK will not   >> <<04567>>09074000
      << allocate the extent for this block.  This will im- >> <<04567>>09076000
      << prove performance and save disc space.             >> <<04567>>09078000
      <<****************************************************>> <<04567>>09080000
                                                               <<04567>>09082000
      IF ACB'ACCCL = DIRACC AND FCONV'ERROR = UNALLOC'EXT THEN <<04567>>09084000
         BEGIN                                                 <<04567>>09086000
         CLEAR'CURR'BUF;        << Clear buffer with fill.  >> <<04567>>09088000
         BLK'TLOG := ACB'BSIZE; << Transfered full amount.  >> <<04567>>09090000
         BLK'LSTAT := 1;        << Successful block "I/O".  >> <<04567>>09092000
         BLK'FLAGS := 0;        << No I/O in progress.      >> <<04567>>09094000
         BLK'IOQX  := 0;                                       <<04567>>09096000
         BLK'UNALLOCEXT := 1; << Indicate un-allocated ext. >> <<04625>>09098000
         PUTBLKPARMS;                                          <<04567>>09100000
         RETURN;                << Successful "I/O" return. >> <<04567>>09102000
         END;                                                  <<04567>>09104000
                                                               <<04567>>09106000
      <<****************************************************>> <<04567>>09108000
      << Normal case, do the ATTACHIO to read block.        >> <<04567>>09110000
      << Stack EXTENT parameter information for ATTACHIO &  >> <<04567>>09112000
      << indicate probable access type in FLAGS word.       >> <<04567>>09114000
      <<****************************************************>> <<04567>>09116000
                                                               <<04567>>09118000
RDAGIN:                                                                 09120000
      TOS := BLK'EXTBASE;                                      <<04653>>09122000
      TOS := BLK'EXTSIZE;                                      <<04653>>09124000
      ATTIOFLAGS.FLG'CNTL := IF FREAD'MODE THEN BUF'SEQ        <<04653>>09126000
                                           ELSE BUF'DIR;       <<04653>>09128000
      IO'STATUS := ATTACHIO(LDEV,0,BUFDST,BUFDISP,             <<04578>>09130000
           IF BLK'REVERSE THEN 13 ELSE 0,                               09132000
           ACB'BSIZE,P1,P2,ATTIOFLAGS);                                 09134000
      << Remove stacked EXTENT information                  >> <<04653>>09136000
      ASMB(DDEL,DEL);                                          <<04653>>09138000
      IF WAITIO'COMP THEN                                      <<04578>>09140000
         BEGIN     << Input has completed; check for EOF >>             09142000
         IF ERR'STAT = EOFSTAT AND LABEL'DEVICE  THEN          <<04578>>09144000
            BEGIN      << is next reel available? >>           <<02545>>09146000
            REELSWITCH(LDEV,0);                                <<02545>>09148000
            IF = THEN                                          <<02545>>09150000
               BEGIN      << Next reel has been mounted. >>    <<02545>>09152000
               ACB'BTFRCT := -1D;                              <<02545>>09156000
               GO RDAGIN;                                      <<02545>>09158000
               END                                             <<02545>>09160000
            ELSE IF < THEN WAITIO'STATUS := NAVLSTAT           <<04578>>09162000
            ELSE ACB'EOF := 1;      << Real EOF. >>            <<02545>>09164000
            END;                                               <<02545>>09166000
         BLK'IOCB := IO'STATUS;    << save status >>           <<04578>>09168000
         BLK'IOQX := 0;    << don't call WAITFORIO >>                   09170000
         END   << input completed. BLK'IOCOMP=1 to call FINISHREAD >>   09172000
      ELSE                                                              09174000
         BEGIN      << Input now in progress >>                         09176000
         << Ignore status and save IOQ Index.               >> <<04578>>09178000
         BLK'IOQX := NOWAIT'IOQX;                              <<04578>>09180000
         END;                                                           09182000
      PUTBLKPARMS;                                                      09184000
      END;   << of subroutine STARTREAD >>                              09186000
$PAGE                                                          <<04557>>09188000
   SUBROUTINE FINISHREAD(IO'PENDING);                          <<04590>>09190000
   VALUE IO'PENDING;LOGICAL IO'PENDING;                        <<04590>>09192000
                                                               <<04590>>09194000
   <<*******************************************************>> <<04590>>09196000
   << Waits for completin of a pending read operation.  If  >> <<04590>>09198000
   << and error occcured, the block buffer is marked empty  >> <<04590>>09200000
   << and the block pointer is advanced for serial I/O.     >> <<04590>>09202000
   << If the block has no I/O pending on it, then it could  >> <<04590>>09204000
   << have come from a prior completed pre-read.  Check the >> <<04590>>09206000
   << block status for errors.                              >> <<04590>>09208000
   << Input variables:                                      >> <<04590>>09210000
   <<     IO'PENDING -                                      >> <<04590>>09212000
   <<        TRUE    -  I/O is pending on this block, call  >> <<04590>>09214000
   <<                   WAYT to check the I/O status.       >> <<04590>>09216000
   <<        FALSE   -  I/O is not pending, check the stat- >> <<04590>>09218000
   <<                   us of the block and report any err- >> <<04590>>09220000
   <<                   ors that occured.  This could occur >> <<04590>>09222000
   <<                   if DONT'WAYT was called to complete >> <<04590>>09224000
   <<                   a pre-read.  The status of the I/O  >> <<04590>>09226000
   <<                   is not checked at that time.        >> <<04590>>09228000
   <<*******************************************************>> <<04590>>09230000
                                                               <<04590>>09232000
   BEGIN                                                       <<04590>>09234000
   IF NOT IO'PENDING THEN                                      <<04590>>09236000
      BEGIN                 << Block was from a pre-read.   >> <<04590>>09238000
      BLK'DONTWAIT := 0;    << Clear don't wait bit.        >> <<04590>>09240000
      IF BLK'LSTAT <> 1 THEN                                   <<04590>>09242000
         BEGIN              << An error occured on the blk. >> <<04590>>09244000
         ACB'STATUS := BLK'LSTAT;                              <<04590>>09246000
         ACB'ERROR  := IOSTAT(ACB'STATUS);                     <<04590>>09248000
         BLK'BLOCK  := -1D;                                    <<04590>>09250000
         GO PEXIT;          << NOW, report the ERROR!       >> <<04590>>09252000
         END;                                                  <<04590>>09254000
      END                                                      <<04590>>09256000
   ELSE                                                        <<04590>>09258000
      IF WAYT(1) THEN                                                   09260000
         BEGIN          << I/O error. Go to next block >>               09262000
         IF ACB'DTYPE=SDISC OR ACB'DTYPE=MTAPE THEN            <<00188>>09264000
            IF ACB'VARIABLE THEN  << Variable record format? >>         09266000
               ACB'BLK := ACB'BLK+1D                                    09268000
            ELSE                                                        09270000
               ACB'FPTR := (BLOCK+1D)*DBLKFACT;                         09272000
         BLK'BLOCK := -1D;  << mark buffer empty >>                     09274000
         GO PEXIT                                                       09276000
         END;       << of I/O error >>                                  09278000
   PUTBLKPARMS;                                                <<04590>>09280000
   END;          << of subroutine FINISHREAD >>                <<04590>>09282000
$PAGE                                                          <<04557>>09284000
   SUBROUTINE STARTWRITE;                                               09286000
      << Called when the block associated with the current              09288000
        buffer must be written to complete an I/O operation.            09290000
        The current buffer is that defined by the BUFDISP pointer. >>   09292000
                                                                        09294000
      BEGIN                                                             09296000
      IF ACB'ACCCL = DIRACC THEN                                        09298000
         BEGIN                                                          09300000
         TOS := 0;         << for LDEV >>                               09302000
         TOS := BLK'DADDR;  << LDEV and sector nr. >>                   09304000
         TOS := TOS&TASL(8)&DLSR(8);  << separate LDEV >>               09306000
         DISKADR := TOS;      << sector nr. >>                          09308000
         LDEV := TOS;                                                   09310000
         END                                                            09312000
      ELSE                                                              09314000
         BEGIN        << Not disk. Set up ATTIO params >>               09316000
         TOS := ACB'CTL;    << P1 - carriage control >>                 09320000
         TOS := ACB'LPCTL;  << P2.(14:2) - line & page control >>       09322000
         TOS.(13:1) := 1;   << allow tape write past EOT >>    <<02054>>09324000
         TOS.(12:1) := NOT ACB'ASCII;  << ASCII/binary format >>        09326000
         P2 := TOS; P1 := TOS                                           09328000
         END;                                                           09330000
      IF BLK'BLOCK > ACB'HIBLK THEN ACB'HIBLK := BLK'BLOCK;             09332000
      BLK'FLAGS := 5;      << Denote write in progress >>               09334000
      IF ACB'DTYPE = MTAPE AND                                 <<02652>>09336000
        (NOT (ACB'UNDEFINED) OR BC<>0) THEN                    <<02652>>09338000
         BEGIN     << Magtape and non-zero write request >>    <<02652>>09340000
         IO'STATUS := WRITE'DENSITY(LDEV);                     <<04578>>09342000
         IF ERR'STAT <> 1 THEN                                 <<04578>>09344000
            GO POST'IO;  << Skip write.  Post error. >>        <<02652>>09346000
         << OK continue with write.                         >> <<04578>>09348000
         END;                                                  <<02652>>09350000
                                                               <<04591>>09352000
      <<****************************************************>> <<04591>>09354000
      << When writing to serialio, we must back space one   >> <<04591>>09356000
      << block for each pre-read performed past the current >> <<04591>>09358000
      << block to properly position the head for the write. >> <<04591>>09360000
      << This number, ACB'TAPEDISP, is obtained in FWRITE   >> <<04591>>09362000
      << by calling FQUIESCE'IO to count the pre-reads.     >> <<04591>>09364000
      <<****************************************************>> <<04591>>09366000
                                                               <<04591>>09368000
      IF ACB'ACCCL = SERIALIO AND ACB'TAPEDISP > 0 THEN        <<04591>>09370000
         BEGIN  << Do Back Space Record for each pre-read.  >> <<04591>>09372000
         WHILE ACB'TAPEDISP > 0 DO                             <<04591>>09374000
            BEGIN                                              <<04591>>09376000
            IO'STATUS := ATTACHIO(LDEV,0,0,0,12,0,0,0,BFLAGS); <<04591>>09378000
            IF ERR'STAT <> 1 THEN                              <<04591>>09380000
               BEGIN        << Error on BSR, check status.  >> <<04591>>09382000
               ACB'ERROR := IOSTAT(WAITIO'STATUS);             <<04591>>09384000
               IF ACB'ERROR <> EOF AND ACB'ERROR <> EOT AND    <<04591>>09386000
                  ACB'ERROR <> TAPERREC                        <<04591>>09388000
                  THEN GO POST'IO;  << True error on BSR.   >> <<04591>>09390000
               END;                                            <<04591>>09392000
            ACB'TAPEDISP := ACB'TAPEDISP - 1;                  <<04591>>09394000
            END;                                               <<04591>>09396000
         ACB'HIBLK := BLK'BLOCK;                               <<04591>>09398000
         END;                                                  <<04591>>09400000
                                                               <<04591>>09402000
      << Determine how much to write.                       >> <<04578>>09404000
                                                               <<04578>>09406000
      IF ACB'FIXED OR ACB'ACCCL = DIRACC THEN                  <<04578>>09408000
         ATTIO'COUNT := ACB'BSIZE                              <<04578>>09410000
      ELSE IF ACB'UNDEFINED THEN                               <<04578>>09412000
         ATTIO'COUNT := -BC                                    <<04578>>09414000
      ELSE                                                     <<04578>>09416000
         ATTIO'COUNT := REC'PNTR + 1;                          <<04578>>09418000
                                                               <<04578>>09420000
                                                               <<04578>>09422000
      <<****************************************************>> <<04578>>09424000
      << Perform ATTACHIO write of buffer to device.  For   >> <<04578>>09426000
      << labeled tape or serial disc, we perform WAIT FOR   >> <<04578>>09428000
      << I/O and check the status now.  For all other files >> <<04578>>09430000
      << (unlabeled tape, disc, etc.), we do NOWAIT I/O.    >> <<04578>>09432000
      << Stack EXTENT parameter information for ATTACHIO &  >> <<04578>>09434000
      << indicate probable access type in FLAGS word.       >> <<04578>>09436000
      <<****************************************************>> <<04578>>09438000
                                                               <<04578>>09440000
      TOS := BLK'EXTBASE;                                      <<04653>>09442000
      TOS := BLK'EXTSIZE;                                      <<04653>>09444000
      ATTIOFLAGS.FLG'CNTL := IF FWRITE'MODE THEN BUF'SEQ       <<04653>>09446000
                                           ELSE BUF'DIR;       <<04653>>09448000
      IO'STATUS := ATTACHIO(LDEV,0,BUFDST,BUFDISP,1,           <<04578>>09450000
                            ATTIO'COUNT,P1,P2,ATTIOFLAGS);     <<04578>>09452000
      << Remove stacked EXTENT information                  >> <<04653>>09454000
      ASMB(DDEL,DEL);                                          <<04653>>09456000
      IF WAITIO'COMP THEN                                      <<04578>>09458000
         BEGIN   << Output has completed. Check for EOT marker >>       09460000
         IF ERR'STAT = EOTSTAT AND LABEL'DEVICE  THEN          <<04578>>09462000
            BEGIN      << is next reel available? >>           <<02545>>09464000
            REELSWITCH(LDEV,1);                                <<02545>>09466000
            IF = THEN                                          <<02545>>09468000
               BEGIN       << Next reel mounted. >>            <<02545>>09470000
               ACB'BTFRCT := -1D;                              <<02545>>09472000
               WAITIO'STATUS := 1;    << No error >>           <<04578>>09474000
               END                                             <<02545>>09476000
            ELSE WAITIO'STATUS := NAVLSTAT;    << =REPLY 0. >> <<04591>>09478000
            END;                                               <<02545>>09480000
POST'IO:                                                       <<02652>>09482000
         BLK'IOCB:= IO'STATUS;        << save status >>        <<04578>>09484000
         END         << output has completed >>                         09486000
      ELSE                                                              09488000
         BEGIN                                                          09490000
         << Ignore status and save IOQ Index.                  <<04578>>09492000
         BLK'IOQX := NOWAIT'IOQX;                              <<04578>>09494000
         END;                                                           09496000
      PUTBLKPARMS;                                                      09498000
      END;          << of subroutine STARTWRITE >>                      09500000
$PAGE                                                          <<04578>>09502000
   SUBROUTINE REVERSEBUF(SIZE);                                         09504000
   VALUE SIZE; LOGICAL SIZE;                                   <<02076>>09506000
<< Used by FREADBACKWARD to reverse the data in the user's              09508000
buffer.  >>                                                             09510000
                                                                        09512000
      BEGIN                                                             09514000
      @BTARGET := @TARGET&LSL(1);                                       09516000
                                                               <<04578>>09518000
      LOC := 0;                                                <<04578>>09520000
      WHILE LOC < SIZE DO                                      <<04578>>09522000
         BEGIN                                                          09524000
         TOS := BTARGET(LOC);                                  <<04578>>09526000
         TOS := BTARGET(LOG(CTT)-1-LOC);                       <<04578>>09528000
         ASMB(XCH);                                            <<02076>>09530000
         BTARGET(X) := TOS;                                    <<02076>>09532000
         BTARGET(LOC) := TOS;                                  <<04578>>09534000
         LOC := LOC+1;                                         <<04578>>09536000
         END;                                                           09538000
      END;       << subroutine REVERSEBUF >>                            09540000
$PAGE                                                          <<04557>>09542000
DOUBLE SUBROUTINE SCANVARBLOCK;                                <<HM.00>>09544000
   << Analyzes the block contained in the current buffer.        HM.00  09548000
                                                                 HM.00  09550000
     Returns - word 0 - buf seg relative addr of block delim     HM.00  09552000
               word 1 - # records in the block. >>             <<02072>>09554000
   BEGIN                                                       <<HM.00>>09556000
   << Scan block for block delimiter >>                        <<02072>>09558000
   TOS := T1ADR;    << set up for record scan >>               <<02072>>09560000
   TOS := BUFDST;                                              <<02072>>09562000
   TOS := BUFDISP;                                             <<02072>>09564000
   DO                                                          <<HM.00>>09566000
      BEGIN       << scan next record >>                       <<02072>>09568000
      TOS := 1;                                                <<02072>>09570000
      ASMB(MDS 1);   << get the count or block delimiter >>    <<02072>>09572000
      IF T1 <> -1 THEN                                         <<HM.00>>09574000
         BEGIN    << Not a delimiter.  Skip over the record >> <<02072>>09576000
         S5 := S5+1;    << Bump block record count >>          <<02072>>09578000
         S2 := S2-1;    << Maintain MDS destination at T1 >>   <<02072>>09580000
         TOS := TOS+(T1+1)&LSR(1);                             <<02072>>09582000
         IF NOT (BUFDISP <= S0 <= BUFDISP+ACB'BSIZE) THEN      <<HM.00>>09584000
            ERREXIT(BADVARBLK);                                <<HM.00>>09586000
         END;                                                  <<HM.00>>09588000
      END UNTIL T1 = -1;                                       <<HM.00>>09590000
   S6 := TOS-1;    << Return delimiter address >>              <<02072>>09592000
   ASMB(DEL,DDEL);                                             <<HM.00>>09594000
   END;    << subroutine SCANVARBLOCK >>                       <<02072>>09596000
                                                               <<HM.00>>09598000
$PAGE                                                          <<04557>>09600000
SUBROUTINE ADJUSTCIRFILE;                                      <<HM.00>>09602000
   << Deletes the first block from the file. >>                <<02072>>09604000
   BEGIN                                                       <<HM.00>>09606000
   IF ACB'VARIABLE THEN                                        <<HM.00>>09608000
      BEGIN    << Must count records in the first block. >>    <<02072>>09610000
      ACB'BLK := ACB'BLK-1D;                                   <<02072>>09612000
      STARTREAD(0D);                                           <<HM.00>>09614000
      FINISHREAD(TRUE);                                        <<04590>>09616000
      TOS := SCANVARBLOCK;                                     <<02072>>09618000
      ASMB(ZROB);                                              <<HM.00>>09620000
      END                                                      <<HM.00>>09622000
   ELSE                                                        <<HM.00>>09624000
      TOS := DBLKFACT;                                         <<02072>>09626000
                                                               <<HM.00>>09628000
   << Adjust counters >>                                       <<02072>>09630000
   ACB'FPTR := ACB'FPTR-DS1;                                   <<02072>>09632000
   FADJUSTCIRFILE(*,ACBMQ);    << adjust FCB >>                <<02072>>09634000
   BLOCK := BLOCK-1D;                                          <<02072>>09636000
                                                               <<HM.00>>09638000
   << Decrement block numbers in the buffers. >>               <<02072>>09640000
   PUTBLKPARMS;                                                <<HM.00>>09642000
   TOS := I;  I := 0;                                          <<02072>>09644000
   DO                                                          <<HM.00>>09646000
      BEGIN     << Adjust a buffer >>                          <<02072>>09648000
      GETBLKPARMS;                                             <<HM.00>>09650000
      IF BLK'BLOCK <> -1D THEN BLK'BLOCK := BLK'BLOCK-1D;      <<02049>>09652000
      PUTBLKPARMS;                                             <<HM.00>>09654000
      END UNTIL (I := I+1) > ACB'NUMBUF;                       <<02072>>09656000
   I := TOS;                                                   <<02072>>09658000
   GETBLKPARMS;                                                <<HM.00>>09660000
   END;    << subroutine ADJUSTCIRFILE >>                      <<02072>>09662000
                                                               <<HM.00>>09664000
                                                               <<HM.00>>09666000
SUBROUTINE FINDFILEND;                                         <<HM.00>>09668000
  << Used on first write to a variable record file which was   <<02072>>09670000
  << opened with Append access.  Reads in last block and finds <<02072>>09672000
  << location of the next available record. >>                 <<02072>>09674000
   BEGIN                                                       <<HM.00>>09676000
   << Read in the last block written >>                        <<02072>>09678000
   I := 0;  GETBLKPARMS;                                       <<02072>>09680000
   STARTREAD(ACB'BLK);                                         <<HM.00>>09682000
   FINISHREAD(TRUE);                                           <<04590>>09684000
   TOS := SCANVARBLOCK;    << Find end of the data area >>     <<02072>>09686000
   DEL;            << discard nr. of records >>                <<02072>>09688000
   REC'PNTR := S0-BUFDISP;                                     <<04578>>09690000
   BUFDISP := TOS;                                             <<02072>>09692000
   END;    << subroutine FINDFILEND >>                         <<02072>>09694000
$PAGE " IOMOVE - UNBUFFERED "                                  <<HM.00>>09696000
<< * * * $$$$   Begin execution    $$$$ * * * >>               <<HM.00>>09698000
                                                               <<HM.00>>09700000
$  IF X0 = ON                                                           09702000
   IF MONOTHER THEN     << monitoring? >>                               09704000
      BEGIN                                                             09706000
      FTITLE("IOMO","VE  ",0D,0D);                                      09708000
      DEBUG                                                             09710000
      END;                                                              09712000
$  IF                                                                   09714000
                                                                        09716000
   <<* * * Initialize variables and check request * * *>>               09718000
                                                                        09720000
   STKDST := PCB'STK;   << fetch stack DST nr. from PCBX(1) >>          09722000
   PUSH(DL,Q);                                                          09724000
   ASMB(XCH,SUB);            << DL-Q for Q-rel addressing >>            09726000
   ASMB(DUP,STAX);                                                      09728000
   X := TOS-AQM1(X);         << (a-Q) <== (DL-Q) - (DL-a) >>            09730000
   Q'1'A := 1-X;             << 1 - (a-Q) >>                            09732000
   TOS := ACB'SPOOLED;                                         <<04143>>09734000
   SPOOLF := IF <> THEN TOS ELSE TOS <> ACB'SPXDDX;            <<04143>>09736000
                                                               <<04578>>09738000
   <<*******************************************************>> <<04578>>09742000
   << TCOUNT cannot exceed 16K words since BC, used as a    >> <<04578>>09744000
   << positive byte count in BUFFERED files, would exceed   >> <<04578>>09746000
   << one integer word.  When using BC in the NOBUF case,   >> <<04578>>09748000
   << care must be taken to always use it as a logical!!!   >> <<04578>>09750000
   <<*******************************************************>> <<04578>>09752000
                                                               <<04578>>09754000
   IF TCOUNT > MAX'WORD'TCOUNT AND NOT ACB'INHIBITBUF          <<04143>>09756000
      THEN ERREXIT(BADTCOUNT);                                 <<04143>>09758000
                                                               <<04143>>09760000
   BC := IF TCOUNT < 0 THEN -TCOUNT ELSE TCOUNT&LSL(1);                 09762000
   WC := (BC+1)&LSR(1);                                                 09764000
   FILL := IF ACB'ASCII THEN "  " ELSE 0;  <<fill character>>           09768000
   NEWEOF := FALSE;                                                     09770000
   RSIZE := (ACB'RSIZE+1)&LSR(1);  << Rec. size (words) >>              09772000
   RSIZE'BRU := RSIZE * 2;  << Record size,Bytes Rounded Up >> <<04644>>09774000
   DBLKFACT := DOUBLE(ACB'BLKFACT);                                     09776000
   DATASIZE := IF NOT ACB'RIO THEN ACB'BSIZE  << words >>               09778000
               ELSE RSIZE*BLKFACT;                             <<00630>>09780000
   LDEV := ACB'DADDR;     << LDEV of device, in case not disk >>        09782000
   MR := ACB'MULTIREC;        << multi-record mode >>                   09784000
   IF NOT ACB'VARIABLE THEN                                             09786000
      BEGIN           << Non-variable record format >>                  09788000
      TOS := ACB'FPTR;     << record number >>                          09790000
      X := BLKFACT;        << blocking factor >>                        09792000
      DIVD;                                                             09794000
      RXB := S0;                                                        09796000
      REC'PNTR := TOS*RSIZE;      << record offset in block >> <<04578>>09798000
      BLOCK := TOS;        << quotient = block nr. >>                   09800000
      END                                                               09802000
   ELSE                                                                 09804000
      BEGIN         << Variable records >>                              09806000
      REC'PNTR := ACB'BUFUSED;                                 <<04578>>09808000
      BLOCK := ACB'BLK;                                                 09810000
      END;                                                              09812000
$PAGE                                                          <<04557>>09816000
   IF ACB'INHIBITBUF THEN                                               09818000
      BEGIN                                                             09820000
                                                                        09822000
<< ******* Unbuffered ******* >>                                        09824000
                                                                        09826000
                                                                        09828000
   SPEC := IF ACB'SPECVAR THEN                                          09830000
      IF ACB'SPXDDX < 0 THEN -1  << output spoofle >>                   09832000
       ELSE 1 << other spoofle access >>   ELSE 0;                      09834000
   IF READ THEN                                                         09836000
   BEGIN                                                                09838000
                                                                        09840000
<< * * *  Unbuffered READ request  * * * >>                             09842000
                                                                        09844000
   <<*******************************************************>> <<04578>>09846000
   << If no-wait completion, then IOWAIT has called us to   >> <<04578>>09848000
   << complete a no-wait I/O request.  Set the xfer counts  >> <<04578>>09850000
   << from the ACB'TLOG, which were set in IOWAIT when com- >> <<04578>>09852000
   << pleting the I/O, and complete the read.  The I/O stat->> <<04578>>09854000
   << us was set in IOWAIT and placed in ACB'STATUS.        >> <<04578>>09856000
   <<*******************************************************>> <<04578>>09858000
                                                               <<04578>>09860000
   IF NOWAITCOMP THEN                                                   09862000
      BEGIN      << No-wait I/O completion >>                           09864000
      CHAR'TRNSFRD := ACB'TLOG;                                <<04578>>09866000
      IF CHAR'TRNSFRD < 0                                      <<04578>>09868000
         THEN CTT := \CHAR'TRNSFRD\  << Positive characters.>> <<04578>>09870000
         ELSE CTT'L := CHAR'TRNSFRD'L * 2;                     <<04578>>09872000
      WTT'L := (CTT'L+1) / 2;       << Positive words.      >> <<04578>>09874000
      ACB'TLOG := 0;                                           <<01698>>09876000
      GO COMPREAD                                                       09878000
      END;                                                              09880000
                                                                        09882000
   ACB'TLOG := 0;                                                       09884000
   ACB'ERROR := 0;                                                      09886000
   ACB'STATUS := 0;                                                     09888000
   ACB'EOF := 0;                                                        09890000
   IF <> THEN GO SAYEOF;       << report prior EOF >>                   09892000
   IF ACB'ACCCL <> DIRACC THEN                                          09894000
      BEGIN            << Not disk. >>                                  09896000
      TOS := ACB'CTL&LSR(8);         << P1.(13:3) - EOF spec. >>        09898000
      TOS.(0:1) := ACB'INHIBCRLF;    << P1.(0:1) - inhibit CR/LF >>     09900000
      TOS := ACB'STOPCHAR&LSL(8);    << P2.(0:8) - stop char. >>        09902000
      IF ACB'DTYPE = TERMINAL THEN                                      09904000
         BEGIN                                                          09906000
         TOS.(9:1) := ACB'XMITCRLF;  << VIEW handshake >>      <<01790>>09908000
         TOS.(10:1) := ACB'TBLOCK;   << disable Block Mode >>           09910000
         TOS.(12:1) := ACB'BINARYIO  << 8-bit transfers >>              09912000
         END                                                            09914000
      ELSE        << not disk or terminal >>                            09916000
         TOS.(12:1) := NOT ACB'ASCII;  << ASCII/binary mode >>          09918000
      P2 := TOS; P1 := TOS;                                             09920000
      NMAX := INFINITE;                                                 09922000
      END;                                                              09924000
   IF WC > ACB'BSIZE AND NOT MR AND NOT (ACB'DTYPE=TERMINAL) THEN       09926000
      WC := ACB'BSIZE;      << limit to one block >>                    09928000
                                                                        09930000
   <<*******************************************************>> <<04578>>09932000
   <<  Each time through the Read LOOP, we will attempt to  >> <<04578>>09934000
   << read all of WTT.  However, the WTT will be lowered to >> <<04578>>09936000
   << the words left in the extent if reading accross multi->> <<04578>>09938000
   << ple extents and we will return here again to read from>> <<04578>>09940000
   << the next extent.                                      >> <<04578>>09942000
   <<*******************************************************>> <<04578>>09944000
                                                               <<04578>>09946000
                                                                        09948000
RLOOP:                                                                  09950000
   WTT := WC;        << try to read it all >>                           09952000
   SHORT'BLOCK := FALSE;  << Assume no short block read.    >> <<04645>>09954000
   IF ACB'ACCCL = DIRACC THEN                                           09956000
      BEGIN          << get LDEV and sector >>                          09958000
                                                               <<04578>>09960000
      <<****************************************************>> <<04578>>09962000
      << FCONV'BLK will return the following:  EOF record #,>> <<04578>>09964000
      << sectors available in the extent and the extent     >> <<04578>>09966000
      << address (LDEV and DISKADDR).                       >> <<04578>>09968000
      <<****************************************************>> <<04578>>09970000
                                                               <<04578>>09972000
      FCONV'ERROR := 0;                                        <<04567>>09974000
      FCONV'BLK(BLOCK,ACBMQ,0,0,0D,0D,0);                      <<04653>>09976000
      EXTSIZE := TOS;                                          <<04653>>09978000
      EXTBASE := TOS;                                          <<04653>>09980000
      FCEOF := TOS;             << Record number of EOF.    >> <<04578>>09982000
      NMAX := FCEOF-ACB'FPTR;   << # of recs left in file.  >> <<04578>>09984000
      IF NMAX <= 0D THEN                                       <<04578>>09986000
         BEGIN  << No more data records left in the file. >>   <<02072>>09988000
         IF NOT ACB'MSGFILE OR NOT FCCHECKFILEND(ACBMQ,BLOCK)  <<01750>>09990000
            THEN GO SAYEOF;                                    <<01750>>09992000
    << Copying msg file, block has only Close hdr records. >>  <<02072>>09994000
         END;                                                  <<01750>>09996000
      IF DS1 = 0D THEN S1 := 1;      << EOF if bad FLAB >>     <<02072>>09998000
      STX := TOS;     << sectors avbl in this extent >>                 10000000
      FCONV'ERROR := TOS;       << Error nr. >>                <<04567>>10002000
      IF FCONV'ERROR > 0  THEN                                 <<04567>>10004000
         BEGIN         << Error of some kind. >>                        10006000
         IF FCONV'ERROR <= 2 THEN GO SAYEOF  << beyond EOF >>  <<04567>>10008000
            ELSE ERREXIT(FCONV'ERROR);   << other error >>     <<04567>>10010000
         END;                                                           10012000
      LDEV := TOS;        << LDEV of requested block >>                 10014000
      DISKADR := TOS;     << sector nr. of requested block >>           10016000
      IF FREADSEEK'MODE THEN GO SETX;   << FPOINT exit      >> <<04592>>10018000
                                                               <<04557>>10020000
      <<****************************************************>> <<04557>>10022000
      << First, cut back word count to number of words left >> <<04557>>10024000
      << in the extent.  Next, for fixed and undefined files>> <<04557>>10026000
      << calculate the number of records left in the file.  >> <<04557>>10028000
      <<****************************************************>> <<04557>>10030000
                                                               <<04557>>10032000
      IF LOG(WTT/128) >= STX THEN WTT := STX*128;              <<04557>>10034000
      IF NOT ACB'VARIABLE THEN                                          10036000
         BEGIN                                                          10038000
         RECS'FILE := FCEOF-BLOCK*DBLKFACT;     << records  >> <<04557>>10040000
         IF RECS'FILE = 0D THEN FTROUBLE(60);   << EOF????? >> <<04557>>10042000
                                                               <<04557>>10044000
         <<*************************************************>> <<04557>>10046000
         << If the number of records is less than one inte- >> <<04557>>10048000
         << ger word, then it is possible that the word cnts>> <<04557>>10050000
         << are larger than the remaining words in the file.>> <<04557>>10052000
         << Therefore, cut back the word counts if needed.  >> <<04557>>10054000
         << For RIO, this number is obtained from the blocks>> <<04557>>10056000
         << rather than records because of the bit map words>> <<04557>>10058000
         << at the end of data records in the block.        >> <<04557>>10060000
         <<*************************************************>> <<04557>>10062000
                                                               <<04557>>10064000
         IF RECS'FILE'0 = 0 THEN                               <<04557>>10066000
            BEGIN                                              <<04557>>10068000
            IF ACB'RIO THEN                                    <<04557>>10070000
               BEGIN                                           <<04557>>10072000
               BLKS'FILE := (RECS'FILE+DBLKFACT-1D)/DBLKFACT;  <<04557>>10074000
               WORDS'FILE := BLKS'FILE * DBL(ACB'BSIZE);       <<04557>>10076000
               END                                             <<04557>>10078000
            ELSE                                               <<04557>>10080000
               WORDS'FILE := RECS'FILE * DBL(RSIZE);           <<04557>>10082000
                                                               <<04557>>10084000
            IF DBL(WTT) > WORDS'FILE THEN                      <<04557>>10086000
               BEGIN   << Cut back counts, can't read > EOF >> <<04557>>10088000
               WTT := INT(WORDS'FILE);                         <<04557>>10090000
               WC  := INT(WORDS'FILE);                         <<04557>>10092000
               END;                                            <<04557>>10094000
            END;                                               <<04557>>10096000
                                                               <<04557>>10098000
         END;                                                           10100000
      END      << get LDEV and sector >>                       <<02545>>10102000
   ELSE IF ACB'DTYPE = MTAPE AND NOT FREADBACKWARD'MODE THEN   <<04592>>10104000
      SET'LPDT'BOT(LDEV,0); << Magtape and not FREADBACKWARD >><<02652>>10106000
                                                                        10108000
   <<*******************************************************>> <<04578>>10110000
   << If the file has blocks ending on even sector bound-   >> <<04578>>10112000
   << ries, then the file is said to be "streamed" and the  >> <<04578>>10114000
   << read from the extent can be done with one ATTACHIO.   >> <<04578>>10116000
   << Otherwise, we must do multiple ATTACHIO's in sizes of >> <<04578>>10118000
   << a block so as not to read the ending block "garbage". >> <<04578>>10120000
   <<*******************************************************>> <<04578>>10122000
                                                               <<04578>>10124000
   IF WTT > ACB'BSIZE AND NOT ACB'STREAM AND NOT (ACB'DTYPE=TERMINAL)   10126000
     THEN WTT := ACB'BSIZE;  << max 1 blk unless terminal or strm MR >> 10128000
                                                                        10130000
READ'MORE'IN'EXTENT:                                           <<04578>>10132000
                                                               <<04578>>10134000
   <<*******************************************************>> <<04578>>10136000
   << Calculate positive characters to transfer.  If TCOUNT >> <<04578>>10138000
   << was sent as bytes, calculate CTT from TCOUNT in case  >> <<04578>>10140000
   << an odd byte count is requested.                       >> <<04578>>10142000
   <<*******************************************************>> <<04578>>10144000
                                                               <<04578>>10146000
   CTT'L := WTT'L * 2;                                         <<04578>>10148000
   IF 0 <= -TCOUNT <= CTT THEN CTT := -TCOUNT;                          10150000
                                                               <<04567>>10152000
   <<*******************************************************>> <<04567>>10154000
   << If we are reading from an un-allocated extent, simply >> <<04567>>10156000
   << fill the users buffer with fill characters. FCONV'BLK >> <<04567>>10158000
   << did not allocate the extent to save time and space.   >> <<04567>>10160000
   <<*******************************************************>> <<04567>>10162000
                                                               <<04567>>10164000
   IF ACB'ACCCL = DIRACC AND FCONV'ERROR = UNALLOC'EXT THEN    <<04567>>10166000
      BEGIN                                                    <<04567>>10168000
      CLEAR'NOBUFF;    << Clear the user's buffers.         >> <<04567>>10170000
      ACB'STATUS := 1; << Successful read.                  >> <<04567>>10172000
      GO COMPREAD;     << Complete the read, no ATTACHIO.   >> <<04567>>10174000
      END;                                                     <<04567>>10176000
                                                               <<04567>>10178000
REREAD:                                                                 10180000
                                                               <<04578>>10182000
   <<*******************************************************>> <<04578>>10184000
   << Perform the ATTACHIO read.  For no-wait I/O, we save  >> <<04578>>10186000
   << the IOQ indeX in the AFT and report a successful read.>> <<04578>>10188000
   << Stack EXTENT information for ATTACHIO.                >> <<04578>>10190000
   <<*******************************************************>> <<04578>>10192000
                                                               <<04578>>10194000
   TOS := EXTBASE;                                             <<04653>>10196000
   TOS := EXTSIZE;                                             <<04653>>10198000
   FIX'ATTACHIO'FLAGS;                                         <<04653>>10200000
   IO'STATUS := ATTACHIO(LDEV,0,DSTX,@TARGET,                  <<04578>>10202000
      IF FREADBACKWARD'MODE THEN 13 ELSE 0,                    <<04592>>10204000
      IF TCOUNT < 0 THEN -CTT ELSE WTT,                                 10206000
      P1,P2,ATTIOFLAGS);                                       <<04653>>10208000
   << Remove stacked EXTENT parameters                      >> <<04653>>10210000
   ASMB(DDEL,DEL);                                             <<04653>>10212000
   IF NOWAIT THEN                                                       10214000
      BEGIN          << We're starting a No-wait input. >>              10216000
      STUFF'IOQX(NOWAIT'IOQX);                                 <<04578>>10220000
      ACB'NOWAITMODE := 0;   << save I/O mode >>                        10222000
      GO SETX               << claim Read was successful >>             10224000
      END;        << start no-wait input >>                             10226000
                                                                        10228000
   <<*******************************************************>> <<04578>>10230000
   << The number of characters transfered, returned by      >> <<04578>>10232000
   << ATTACHIO, should always be the same as CTT (or WTT)   >> <<04578>>10234000
   << for disc files.  However, for tape files and other    >> <<04578>>10236000
   << devices, the transfer log could be less than the      >> <<04578>>10238000
   << desired amount (CTT or WTT).                          >> <<04578>>10240000
   <<*******************************************************>> <<04578>>10242000
                                                               <<04578>>10244000
   CHAR'TRNSFRD := WAITIO'TLOG;                                <<04578>>10246000
   ACB'STATUS := WAITIO'STATUS; << Save logical I/O status. >> <<04578>>10248000
   IF LABEL'DEVICE AND ACB'STATUS=EOFSTAT THEN                 <<03582>>10250000
      BEGIN       << Is next reel available? >>                <<02545>>10252000
      REELSWITCH(LDEV,0);                                      <<02545>>10254000
      IF = THEN                                                <<02545>>10256000
         BEGIN      << Next reel has been mounted. >>          <<02545>>10258000
         ACB'BTFRCT := -1D;                                    <<02545>>10260000
         GO REREAD;                                            <<02545>>10262000
         END                                                   <<02545>>10264000
      ELSE IF < THEN ACB'STATUS := NAVLSTAT;    << =REPLY 0 >> <<02545>>10266000
      END;                                                     <<02545>>10268000
                                                               <<04578>>10270000
COMPREAD:                                                               10272000
                                                               <<04578>>10274000
   <<*******************************************************>> <<04578>>10276000
   << Make Characters Transfered a positive byte count. The >> <<04578>>10278000
   << TLOG is returned from ATTACHIO as a negative byte     >> <<04578>>10280000
   << count or a positive word count.                       >> <<04578>>10282000
   <<*******************************************************>> <<04578>>10284000
                                                               <<04578>>10286000
   IF CHAR'TRNSFRD < 0                                         <<04578>>10288000
      THEN CHAR'TRNSFRD := \CHAR'TRNSFRD\                      <<04578>>10290000
      ELSE CHAR'TRNSFRD'L := CHAR'TRNSFRD'L * 2;               <<04578>>10292000
                                                               <<04578>>10294000
   IF FREADBACKWARD'MODE THEN REVERSEBUF(CTT/2);               <<04592>>10296000
                                                               <<04578>>10298000
   <<*******************************************************>> <<04578>>10300000
   << Check ATTACHIO status for error condition.  Do BREAK- >> <<04578>>10302000
   << MODE stuff, if needed or return proper FSERR.         >> <<04578>>10304000
   <<*******************************************************>> <<04578>>10306000
                                                               <<04578>>10308000
   IF ACB'STATUS <> 1 THEN                                              10310000
      BEGIN           << ATTACHIO error >>                              10312000
      IF ACB'STATUS = BREAKSTAT AND NOT ACB'NOWAIT THEN                 10314000
         BEGIN                                                          10316000
                                                                        10318000
         <<*************************************************>> <<04578>>10320000
         << User hit BREAK on his terminal.  By the time we >> <<04578>>10322000
         << get here, the terminal driver has called BREAK- >> <<04578>>10324000
         << JOB, which fired a pseudo-interrupt to call the >> <<04578>>10326000
         << CI.  The CI calls FBREAK, which calls LOC'ACB to>> <<04578>>10328000
         << shuffle the control block queue.  At this point,>> <<04578>>10330000
         << the CI is impeded because LOC'ACB hasn't com-   >> <<04578>>10332000
         << completed, since we have the PACB.              >> <<04578>>10334000
         <<*************************************************>> <<04578>>10336000
                                                                        10338000
         IF PCB'PTYPE = 1 THEN                                          10340000
            BEGIN             << CI. Ignore break request  >>           10342000
            GO SETX        << make I/O look OK >>                       10344000
            END;                                                        10346000
                                                                        10348000
         <<*************************************************>> <<04578>>10350000
         << Release the PACB (setting Break mode) so that   >> <<04578>>10352000
         << the CI can read the terminal.                   >> <<04578>>10354000
         <<*************************************************>> <<04578>>10356000
                                                                        10358000
         ACB'BREAK := 1;                                                10360000
         IF = THEN ACBSAVEEOFS := ACBEOFS;                              10362000
         UNLOC'ACB(ACBMQ,2);                                            10364000
                                                                        10366000
         <<*************************************************>> <<04578>>10368000
         << Re-request the PACB.  By now, the CI has it, but>> <<04578>>10370000
         << will keep it only during the FBREAK call.  How- >> <<04578>>10372000
         << ever, since we are not running the CI, LOC'ACB  >> <<04578>>10374000
         << will impede us in the low priority queue until  >> <<04578>>10376000
         << the CI sees :RESUME or :ABORT and calls FUNBREAK>> <<04578>>10378000
         << which will put our request back into the normal >> <<04578>>10380000
         << queue and unimpede us.  The FUNBREAK call spec- >> <<04578>>10382000
         << ifies whether to redo or abort the Read.        >> <<04578>>10384000
         <<*************************************************>> <<04578>>10386000
                                                                        10388000
         LOC'ACB(0,ACBMQ,ACB'FNUM,%100000);                             10390000
         DEL;          << discard DSTX >>                               10392000
         IF NOT ACB'ABORTREAD THEN                                      10394000
            BEGIN             << re-do the read >>                      10396000
            DT1T2 := "READ";                                            10398000
            DT3T4 := " pen";                                            10400000
            DT5T6 := "ding";                                            10402000
            ATTACHIO(LDEV,0,STKDST,Q'1'A,1,-12,0,0,BFLAGS);             10404000
            ACB'TLOG := 0;     << clear xmit log >>                     10406000
            GO REREAD;                                                  10408000
            HELP;         << dummy call >>                              10410000
            END;             << re-do the read >>                       10412000
                                                                        10414000
         ACB'STATUS := EOFCODE  << Abort; simulate EOF >>               10416000
         END;         << broken terminal read >>                        10418000
                                                                        10420000
      <<****************************************************>> <<04578>>10422000
      << If an EOF was encounterd on the first READ, report >> <<04578>>10424000
      << it.  If encountered on a subsequent READ, report   >> <<04578>>10426000
      << the good data read so far, and save the EOF to re- >> <<04578>>10428000
      << port in the next FREAD.                            >> <<04578>>10430000
      <<****************************************************>> <<04578>>10432000
                                                                        10434000
      IF ACB'GSTATUS = EOFCODE THEN                                     10436000
         BEGIN          << EOF. >>                                      10438000
         IF ACB'TLOG <> 0 THEN                                          10440000
            BEGIN     << Report EOF later. >>                           10442000
            ACB'EOF := 1;                                               10444000
            GO SETX                                                     10446000
            END;                                                        10448000
SAYEOF:  ACB'EOFS := 3;     << EOF on $STDIN & $STDINX >>      <<01759>>10450000
SOFTEOF: ACB'STATUS := EOFCODE;                                <<01759>>10452000
         ACB'ERROR := EOF;                                     <<01759>>10454000
         GO EXIT;                                              <<01759>>10456000
         END;      << EOF >>                                            10458000
                                                                        10460000
      ACB'ERROR := IOSTAT(ACB'STATUS);    << Error nr. >>               10462000
      IF ACB'ERROR <> TAPERREC AND ACB'ERROR <> EOL THEN GO EXIT        10464000
      END          << ATTACHIO error >>                                 10466000
   ELSE      << Successful I/O >>                                       10468000
                                                               <<04578>>10470000
      <<****************************************************>> <<04578>>10472000
      << Successfull I/O, check for :EOD condition.         >> <<04578>>10474000
      <<****************************************************>> <<04578>>10476000
                                                               <<04578>>10478000
      IF CHAR'TRNSFRD'L <> 0 AND ACB'CTL.(11:1) THEN           <<04578>>10480000
         BEGIN   << Non-CI job or session. Ck for log EOF. >>           10482000
                                                               <<04578>>10484000
         T1 := TARGET;                                                  10486000
         IF CHAR'TRNSFRD'L > 3  AND                            <<04578>>10488000
            (LT1 LAND %177737) = ":E" AND                      <<04578>>10490000
            (TARGET(1) LAND %157737) = "OD" THEN GO SAYEOF;    <<04578>>10492000
         IF NOT ACB'CTL AND (T1.(0:8) = ":") THEN                       10494000
            BEGIN        << ":" on $STDIN >>                            10496000
            ACB'EOFS := 1 LOR ACB'EOFS;                                 10498000
            GO SOFTEOF;                                        <<01759>>10500000
            END                                                         10502000
         END;        << check for logical EOF >>                        10504000
                                                                        10506000
   <<*******************************************************>> <<04578>>10508000
   << Calculate number of blocks read, this xfer and update >> <<04578>>10510000
   << BLOCK number and block transfer count.                >> <<04578>>10512000
   <<*******************************************************>> <<04578>>10514000
                                                               <<04578>>10516000
   BLKS'TRNSFRD := DBL( (WTT'L+ACB'BSIZE'L-1)/ACB'BSIZE'L );   <<04578>>10518000
   IF BLKS'TRNSFRD = 0D                                        <<04578>>10520000
      THEN BLKS'TRNSFRD := 1D;  << Claim one block read.    >> <<04578>>10522000
                                                               <<04578>>10524000
   BLOCK := BLOCK+BLKS'TRNSFRD;                                <<04578>>10526000
   ACB'BTFRCT := ACB'BTFRCT+BLKS'TRNSFRD; << Block xfer cnt >> <<04578>>10528000
                                                                        10530000
   <<*******************************************************>> <<04578>>10532000
   << For variable length files, check the block structure  >> <<04578>>10534000
   << of the blocks read and set record transfer count,     >> <<04578>>10536000
   << obtained in CHKVARBLK.                                >> <<04578>>10538000
   <<*******************************************************>> <<04578>>10540000
                                                               <<04578>>10542000
   IF ACB'VARIABLE THEN                                                 10544000
      BEGIN           << variable record format >>                      10546000
      ACB'BLK := BLKS'TRNSFRD+ACB'BLK;                         <<04578>>10548000
      << Check the variable structure.                      >> <<04578>>10550000
      IF CHKVARBLK THEN                                        <<04578>>10552000
         BEGIN                                                          10554000
         ACB'STATUS := 0;                                               10556000
         ERREXIT(BADVARBLK);                                            10558000
         END;                                                           10560000
      IF NOT ACB'MSGFILE THEN                                  <<01750>>10562000
         CHAR'TRNSFRD'L := LOG(VAR'WORD'CNT) * 2;              <<04578>>10564000
      RECS'TRNSFRD := NUM'VAR'RECS; << # of records xferedl.>> <<04578>>10566000
      END                                                               10568000
   ELSE                                                                 10570000
      BEGIN            << non-variable >>                               10572000
      << Number of records read, this xfer.                 >> <<04578>>10574000
      RECS'TRNSFRD := BLKS'TRNSFRD * DBLKFACT;                 <<04578>>10576000
      END;                                                              10578000
                                                               <<04578>>10580000
   << Update record pointer and transfer counts.            >> <<04578>>10582000
                                                               <<04578>>10584000
   ACB'FPTR := RECS'TRNSFRD+ACB'FPTR;   << next record nr.  >> <<04578>>10586000
   ACB'RTFRCT := RECS'TRNSFRD+ACB'RTFRCT; << Bump xfer cnt. >> <<04578>>10588000
                                                                        10590000
   <<*******************************************************>> <<04578>>10592000
   << The transfer count will never be less for a disk file,>> <<04578>>10594000
   << but could be short for tape and other device files.   >> <<04578>>10596000
   <<*******************************************************>> <<04578>>10598000
                                                               <<04578>>10600000
   CHARS'TO'FILL := CTT'L-CHAR'TRNSFRD'L;  << Need to fill? >> <<04578>>10602000
   IF ACB'FIXED AND CHARS'TO'FILL > 0 THEN                     <<04578>>10604000
      BEGIN         << pad short block with fill chars. >>              10606000
      SHORT'BLOCK := TRUE;                                     <<04645>>10608000
      @BTARGET := @TARGET&LSL(1);                                       10610000
      BTARGET(CHAR'TRNSFRD'L) := BYTE(FILL);                   <<04578>>10612000
      IF CHAR'TRNSFRD'L > 1 THEN                               <<04578>>10614000
         MOVE BTARGET(CHAR'TRNSFRD'L+1) :=                     <<04578>>10616000
              BTARGET(CHAR'TRNSFRD'L),(CHARS'TO'FILL-1);       <<04578>>10618000
      << Round up to full records.                          >> <<04578>>10620000
      CHAR'TRNSFRD'L := CHAR'TRNSFRD'L + RSIZE'BRU - 1;        <<04644>>10622000
      CHAR'TRNSFRD'L :=                                        <<04578>>10624000
            CHAR'TRNSFRD'L-(CHAR'TRNSFRD'L MOD RSIZE'BRU);     <<04644>>10626000
      END;         << pad short block >>                                10628000
                                                               <<04645>>10630000
   <<*******************************************************>> <<04578>>10632000
   << Update transfer count and ACB transfer log.  CORREC-  >> <<04578>>10634000
   << TION term is negative byte count or a positive word.  >> <<04578>>10636000
   <<*******************************************************>> <<04578>>10638000
                                                               <<04578>>10640000
   IF TCOUNT < 0                                               <<04578>>10642000
      THEN CORRECTION := -CHAR'TRNSFRD                         <<04578>>10644000
      ELSE CORRECTION := CHAR'TRNSFRD'L&LSR(1); << Need LSR!>> <<04578>>10646000
   TCOUNT := TCOUNT-CORRECTION;                                <<04578>>10648000
   ACB'TLOG := CORRECTION+ACB'TLOG;                            <<04578>>10650000
                                                                        10652000
   <<*******************************************************>> <<04578>>10654000
   << For MR, continue reading if needed.  Terminals are    >> <<04578>>10656000
   << allowed only one ATTACHIO per read!                   >> <<04578>>10658000
   <<*******************************************************>> <<04578>>10660000
                                                               <<04578>>10662000
   IF MR AND NOT (ACB'DTYPE=TERMINAL) THEN                              10664000
      BEGIN                                                             10666000
                                                               <<04578>>10668000
      <<****************************************************>> <<04578>>10670000
      << Calculate actual words transferred.  This should be>> <<04578>>10672000
      << the same for disc files but could be less for tape >> <<04578>>10674000
      << and other device files.                            >> <<04578>>10676000
      <<****************************************************>> <<04578>>10678000
                                                               <<04578>>10680000
      WTT'L := (CHAR'TRNSFRD'L+1) / 2;                         <<04578>>10682000
      @TARGET := @TARGET+WTT;       << update target addr. >>           10684000
      WC := WC-WTT;                 << update word count >>             10686000
                                                               <<04578>>10688000
      <<****************************************************>> <<04578>>10690000
      << If reading more than one blocks worth from the     >> <<04578>>10692000
      << file, then one of two things can happen.  If there >> <<04578>>10694000
      << is room left in the extent (than the file was not  >> <<04578>>10696000
      << streamed) then READ MORE IN EXTENT.  Otherwise,    >> <<04578>>10698000
      << read more in the next extent.  For device files,   >> <<04578>>10700000
      << simply go through the READ LOOP again.             >> <<04578>>10702000
      <<****************************************************>> <<04578>>10704000
                                                               <<04578>>10706000
      IF ACB'ACCCL=DIRACC THEN                                          10708000
         BEGIN    << bump disk address >>                               10710000
         NMAX := FCEOF-ACB'FPTR;                                        10712000
         IF <= THEN GO EXIT;   << at EOF, but data is good >>           10714000
         << Calculate number of sectors read, this transfer.>> <<04578>>10716000
         SECTS'TRNSFRD := (WTT'L + 127) / 128;                 <<04578>>10718000
         STX := STX - SECTS'TRNSFRD;   << Decrement sectors >> <<04578>>10720000
         DISKADR := DISKADR + DBL(SECTS'TRNSFRD); << Next . >> <<04578>>10722000
         IF WTT > WC THEN WTT := WC;   << last xfer is short >>         10724000
         IF WC > 0 AND STX > 0                                 <<04578>>10726000
            THEN GO READ'MORE'IN'EXTENT;                       <<04578>>10728000
         END;                                                           10730000
                                                               <<04645>>10732000
      <<****************************************************>> <<04645>>10734000
      << Non disk files, continue reading untill complete.  >> <<04645>>10736000
      << For tape files, we could have a short block read.  >> <<04645>>10738000
      << If so, and the remaining word count is less than a >> <<04645>>10740000
      << block, then don't read again because the user will >> <<04645>>10742000
      << lose the remaining data in the next block on subse->> <<04645>>10744000
      << quent reads.                                       >> <<04645>>10746000
      <<****************************************************>> <<04645>>10748000
                                                               <<04645>>10750000
      IF WC > 0 AND NOT(SHORT'BLOCK LAND WC < ACB'BSIZE)       <<04645>>10752000
         THEN GO RLOOP;   << Go back, go back, go back!!!!! >> <<04645>>10754000
      END;      << MR >>                                                10756000
   END                                                                  10758000
$PAGE                                                          <<04578>>10760000
ELSE                                                                    10762000
   BEGIN                                                                10764000
                                                                        10766000
<< * * *  Unbuffered WRITE request  * * * >>                            10768000
                                                                        10770000
   <<*******************************************************>> <<04578>>10772000
   << IOWAIT has called us to complete the write on a no-   >> <<04578>>10774000
   << wait I/O request.  Set the transfer counts based on   >> <<04578>>10776000
   << ACB'TLOG, previously initialized in IOWAIT.  The I/O  >> <<04578>>10778000
   << status was placed in ACB'STATUS by IOWAIT also.       >> <<04578>>10780000
   <<*******************************************************>> <<04578>>10782000
                                                               <<04578>>10784000
   IF NOWAITCOMP THEN                                                   10786000
      BEGIN            << No-wait write completion >>                   10788000
      NEWEOF := ACB'NOWAITEOF;   << Restore EOF Advanced flag >>        10790000
      CHAR'TRNSFRD := ACB'TLOG;                                <<04578>>10792000
      << Obtain Words To Transfer count.                    >> <<04578>>10794000
      IF CHAR'TRNSFRD >= 0                                     <<04578>>10796000
         THEN WTT := CHAR'TRNSFRD     << Positive words.    >> <<04578>>10798000
         ELSE WTT := (\CHAR'TRNSFRD\+1)/2;                     <<04578>>10800000
      DISKADR := ACB'NOWAITDA;   << restore for FCLEAR, later >>        10802000
      LDEV := ACB'NOWAITLDEV;                                           10804000
      GO COMPWRITE                                                      10806000
      END;                                                              10808000
                                                                        10810000
   FIRST'WRITE := TRUE;    << Used for pre-spacing.         >> <<04578>>10812000
   ACB'TLOG := 0;                                                       10814000
   ACB'STATUS := 0;                                                     10816000
   ACB'ERROR := 0;                                             <<02076>>10818000
   NMAX := INFINITE;                                                    10820000
   IF ACB'ACCCL <> DIRACC THEN                                          10822000
      BEGIN           << non-disk >>                                    10824000
      LDEV := ACB'DADDR;    << LDEV of device >>                        10826000
      TOS := ACB'CTL;            << P1 - carriage control >>            10828000
      TOS := ACB'LPCTL;          << P2.(14:2) - line & page control >>  10830000
      TOS.(13:1) := 1;   << allow tape write past EOT >>       <<02054>>10832000
      IF ACB'DTYPE = TERMINAL THEN                                      10834000
         BEGIN                                                          10836000
         TOS.(12:1) := ACB'BINARYIO;  << 8-bit transfers >>             10838000
         TOS.(0:1) := ACB'QUIESCE;                                      10840000
         END                                                            10842000
      ELSE         << not disk or terminal >>                           10844000
         TOS.(12:1) := NOT ACB'ASCII;  << ASCII/binary mode >>          10846000
      P2 := TOS; P1 := TOS                                              10848000
      END;                                                              10850000
   IF WC > ACB'BSIZE AND ACB'DTYPE <> TERMINAL AND NOT MR THEN          10852000
      ERREXIT(BADTCOUNT);        << Ugh! Too much. >>                   10854000
                                                                        10856000
   <<*******************************************************>> <<04578>>10858000
   <<  The WTT count will be lowered to the maximum number  >> <<04578>>10860000
   << of words left in the extent on each pass through the  >> <<04578>>10862000
   << Write LOOP if we are writing a greater amount than    >> <<04578>>10864000
   << what is left in the present extent.                   >> <<04578>>10866000
   <<*******************************************************>> <<04578>>10868000
                                                               <<04578>>10870000
                                                                        10872000
WLOOP:                                                                  10874000
   WTT := WC;       << try to write it all >>                           10876000
   IF ACB'ACCCL = DIRACC THEN                                           10878000
      BEGIN           << get LDEV and sector >>                         10880000
                                                               <<04578>>10882000
      <<****************************************************>> <<04578>>10884000
      << Obtain disc address parameters from FCONV'BLK and  >> <<04578>>10886000
      << determine if we are writing beyond the file limit. >> <<04578>>10888000
      <<****************************************************>> <<04578>>10890000
                                                               <<04578>>10892000
      FCONV'BLK(BLOCK,ACBMQ,MODE,0,0D,0D,0);                   <<04653>>10894000
      EXTSIZE := TOS;  << save current extent size >>          <<04653>>10896000
      EXTBASE := TOS;  << save current extent base >>          <<04653>>10898000
      FCEOF := TOS;                                                     10900000
      STX := TOS;     << sectors avbl in this extent >>                 10902000
      FCONV'ERROR := TOS;       << Error nr. >>                <<04578>>10904000
      IF FCONV'ERROR <> 0 THEN                                 <<04578>>10906000
         BEGIN       << Error of some kind. >>                          10908000
         IF FCONV'ERROR = 1 THEN                               <<04578>>10910000
            NEWEOF := TRUE   << Set EOF advanced flag >>                10912000
         ELSE IF FCONV'ERROR = 2 THEN                          <<04578>>10914000
            BEGIN                                                       10916000
ATFLIM:     ACB'ERROR := EOF;                                           10918000
            ACB'STATUS := EOFCODE;                                      10920000
            GO EXIT                                                     10922000
            END                                                         10924000
         ELSE      << other error >>                                    10926000
            ERREXIT(FCONV'ERROR);                              <<04578>>10928000
         END;                                                           10930000
      LDEV := TOS;     << LDEV of requested block >>                    10932000
      DISKADR := TOS;  << sector nr. of requested block >>              10934000
      IF WRITE'EOF'MODE THEN GO EXIT;                          <<04592>>10936000
      IF LOG(WTT&ASR(7)) >= STX THEN WTT := STX&LSL(7);                 10938000
      END;     << get LDEV and sector >>                                10940000
                                                                        10942000
   <<*******************************************************>> <<04578>>10944000
   <<   Terminal writes of length >  ACB'BSIZE  are  broken >> <<04578>>10946000
   << into multiple calls to  ATTACHIO, each of length ACB' >> <<04578>>10948000
   << BSIZE (except poss. the last).  The following  state- >> <<04578>>10950000
   << ment  makes  sure the  carriage  control parm is sent >> <<04578>>10952000
   << with the first call   if the terminal is in  prespace >> <<04578>>10954000
   << mode or   the last such call if in postspace mode.    >> <<04578>>10956000
   <<*******************************************************>> <<04578>>10958000
                                                               <<02310>>10960000
   IF ACB'DTYPE = TERMINAL THEN                                <<04578>>10962000
      IF ACB'LINECTL = 0 THEN   <<  Post spacing.           >> <<04578>>10964000
         BEGIN                                                 <<04578>>10966000
         IF WTT <= ACB'BSIZE    << Last write.              >> <<04644>>10968000
            THEN P1 := ACB'CTL  << Perform the CCTL func.   >> <<04578>>10970000
            ELSE P1 := %320;    << No CCLF.                 >> <<04578>>10972000
         END                                                   <<04578>>10974000
      ELSE                      << Pre spacing, bit is on.  >> <<04578>>10976000
         IF FIRST'WRITE         << First write.             >> <<04578>>10978000
            THEN P1 := ACB'CTL  << Perform the CCTL func.   >> <<04578>>10980000
            ELSE P1 := %320;    << No CCLF.                 >> <<04578>>10982000
                                                               <<04578>>10984000
   FIRST'WRITE := FALSE;        << Past the first write.    >> <<04578>>10986000
$PAGE                                                          <<04578>>10988000
   <<*******************************************************>> <<04578>>10990000
   << If the blocks end on even sector boundries, then the  >> <<04578>>10992000
   << file is said to be "streamed" and the write can be    >> <<04578>>10994000
   << completed for this extent with a single ATTACHIO.     >> <<04578>>10996000
   << Otherwise, the ATTACHIO's will be done in sizes of a  >> <<04578>>10998000
   << block since the blocks are not on sector boundries.   >> <<04578>>11000000
   <<*******************************************************>> <<04578>>11002000
                                                               <<04578>>11004000
   IF WTT > ACB'BSIZE AND NOT ACB'STREAM THEN                           11006000
      WTT := ACB'BSIZE;   << limit to one block unless streamed >>      11008000
                                                               <<04578>>11010000
WRITE'MORE'IN'EXTENT:                                          <<04578>>11012000
                                                               <<04578>>11014000
   <<*******************************************************>> <<04578>>11016000
   << Calculate positive characters to transfer.  If TCOUNT >> <<04578>>11018000
   << was sent as bytes, then calculate CTT from TCOUNT in  >> <<04578>>11020000
   << case an odd byte count has been requested.            >> <<04578>>11022000
   <<*******************************************************>> <<04578>>11024000
                                                               <<04578>>11026000
   CTT'L := WTT'L * 2;                                         <<04578>>11028000
   IF 0 <= -TCOUNT <= CTT THEN CTT := -TCOUNT;                          11030000
                                                               <<04578>>11032000
   <<*******************************************************>> <<04578>>11034000
   << Check users buffer to insure that the data has the    >> <<04578>>11036000
   << correct formats and structures for message or variable>> <<04578>>11038000
   << files before being written to disk.                   >> <<04578>>11040000
   <<*******************************************************>> <<04578>>11042000
                                                               <<04578>>11044000
   IF ACB'MSGFILE THEN                                         <<HM.00>>11046000
      BEGIN    << Insure that the block has correct format >>  <<02072>>11048000
      TOS:=FCHECKMSGBLOCK(TARGET,WTT);                         <<HM.00>>11050000
      IF < THEN ERREXIT(BADVARBLK);                            <<HM.00>>11052000
      NONDATARECORDS := TOS; ASMB(ZERO,XCH);                   <<04578>>11054000
      TOS := NUM'VAR'RECS;                                     <<04578>>11056000
      END                                                      <<HM.00>>11058000
   ELSE IF ACB'VARIABLE THEN                                   <<HM.00>>11060000
      BEGIN                                                             11062000
      IF CHKVARBLK                                             <<04578>>11064000
         THEN ERREXIT(BADVARBLK);                              <<04578>>11066000
      IF ACB'ACCCL=DIRACC THEN NEWEOF := TRUE; << EOF Advanced flag >>  11068000
      END;                                                              11070000
                                                                        11072000
   IF ACB'DTYPE = MTAPE AND CTT <> 0 THEN                      <<02652>>11074000
      BEGIN     << Magtape and non-zero write request >>       <<02652>>11076000
      IO'STATUS := WRITE'DENSITY(LDEV);                        <<04578>>11078000
      IF ERR'STAT <> 1 THEN                                    <<04578>>11080000
         BEGIN                                                 <<02652>>11082000
         << Ignore transmission log and save logical status.>> <<04578>>11084000
         ACB'STATUS := WAITIO'STATUS;                          <<04578>>11086000
         GO COMPWRITE;        << Skip write.  Report error. >> <<02652>>11088000
         END;                                                  <<02652>>11090000
      << A-OK, continue with write.                        >>  <<04578>>11092000
      END;                                                     <<02652>>11094000
                                                               <<04578>>11096000
   <<*******************************************************>> <<04578>>11098000
   << Perform the ATTACHIO write.  For no-wait I/O, stuff   >> <<04578>>11100000
   << the IOQ indeX into the AFT and report no error.       >> <<04578>>11102000
   << Stack file EXTENT parameters on TOS for ATTACHIO.     >> <<04578>>11104000
   <<*******************************************************>> <<04578>>11106000
                                                               <<04578>>11108000
      TOS := EXTBASE;                                          <<04653>>11110000
      TOS := EXTSIZE;                                          <<04653>>11112000
      << Fix FLAGS word for ATTACHIO >>                        <<04653>>11114000
      FIX'ATTACHIO'FLAGS;                                      <<04653>>11116000
   IO'STATUS := ATTACHIO(LDEV,0,DSTX,@TARGET,                  <<04578>>11118000
      IF ACB'DTYPE=SDISC THEN MODE ELSE 1,                              11120000
      IF TCOUNT < 0 THEN -CTT ELSE WTT,                                 11122000
      P1,P2,ATTIOFLAGS);                                       <<04578>>11124000
                                                               <<04578>>11126000
      << Remove stacked EXTENT parameters >>                   <<04653>>11128000
      ASMB(DDEL,DEL);                                          <<04653>>11130000
   IF NOWAIT THEN                                                       11132000
      BEGIN    << We began a no-wait write. Save IOQX in AFT >>         11134000
      STUFF'IOQX(NOWAIT'IOQX);                                 <<04578>>11138000
      ACB'NOWAITEOF := NEWEOF;   << save EOF advanced flag >>           11140000
      ACB'NOWAITMODE := 1;       << save I/O mode >>                    11142000
      ACB'NOWAITDA := DISKADR;                                          11144000
      ACB'NOWAITLDEV := LDEV;                                           11146000
      GO SETX            << claim I/O was successful >>                 11148000
      END;    << start no-wait write >>                                 11150000
                                                                        11152000
   <<*******************************************************>> <<04578>>11154000
   << Update the appropriate counts based on the trans-     >> <<04578>>11156000
   << mission log returned by ATTACHIO.  This TLOG should   >> <<04578>>11158000
   << be the same as the requested counts for all files ex- >> <<04578>>11160000
   << cept when hitting EOT on a tape file.                 >> <<04578>>11162000
   <<*******************************************************>> <<04578>>11164000
                                                               <<04578>>11166000
   TCOUNT := TCOUNT-WAITIO'TLOG;<< Decrement count. >>         <<04578>>11168000
   ACB'TLOG := WAITIO'TLOG+ACB'TLOG;  << update xmit log >>    <<04578>>11170000
   ACB'STATUS := WAITIO'STATUS;   << save logical I/O status>> <<04578>>11172000
   IF LABEL'DEVICE AND ACB'STATUS = EOTSTAT THEN               <<03582>>11174000
      BEGIN        << Is next reel available? >>               <<02545>>11176000
      REELSWITCH(LDEV,1);                                      <<02545>>11178000
      IF = THEN                                                <<02545>>11180000
         BEGIN        << Next reel mounted. >>                 <<02545>>11182000
         ACB'BTFRCT := -1D;                                    <<02545>>11184000
         ACB'STATUS := 1;    << No error >>                    <<02545>>11186000
         END                                                   <<02545>>11188000
      ELSE ACB'STATUS := NAVLSTAT;     << =REPLY 0. >>         <<02545>>11190000
      END;                                                     <<02545>>11192000
                                                               <<04578>>11194000
   <<*******************************************************>> <<04578>>11196000
   << To complete the write, check the ATTACHIO status re-  >> <<04578>>11198000
   << turned  and convert it to an FSERR if necessary.      >> <<04578>>11200000
   <<*******************************************************>> <<04578>>11202000
                                                               <<04578>>11204000
COMPWRITE:                                                              11206000
   IF ACB'STATUS <> 1 THEN                                              11208000
      BEGIN         << ATTACHIO reports error >>                        11210000
      IF ACB'GSTATUS = EOFCODE THEN                                     11212000
         BEGIN             << File limit encountered. >>                11214000
         ACB'EOFS := 3;                                                 11216000
         ACB'EOF := 1                                                   11218000
         END;                                                           11220000
      ACB'ERROR := IOSTAT(ACB'STATUS);      << error nr. >>             11222000
      IF ACB'ERROR <> EOT AND ACB'ERROR <> TAPERREC THEN GO EXIT        11224000
      END;         << ATTACHIO error >>                                 11226000
                                                                        11228000
   <<*******************************************************>> <<04578>>11230000
   << Calculate the number of blocks written this transfer. >> <<04578>>11232000
   << If WTT is not a multiple of the block size, EOFDELTA  >> <<04578>>11234000
   << is set to the word remainder of the un-written block  >> <<04578>>11236000
   << portion for calculating EOF and amounts to clear.     >> <<04578>>11238000
   <<*******************************************************>> <<04578>>11240000
                                                               <<04578>>11242000
   BLKS'TRNSFRD := DBL( (WTT'L+ACB'BSIZE'L-1) / ACB'BSIZE'L);  <<04578>>11244000
   IF BLKS'TRNSFRD = 0D                                        <<04578>>11246000
      THEN BLKS'TRNSFRD := 1D;  << Claim one block write.   >> <<04578>>11248000
   EOFDELTA := WTT MOD ACB'BSIZE;                              <<04578>>11250000
                                                               <<04578>>11252000
   << Update BLOCK number and block transfer count.         >> <<04578>>11254000
                                                               <<04578>>11256000
   BLOCK := BLOCK + BLKS'TRNSFRD;                              <<04578>>11258000
   ACB'BTFRCT := ACB'BTFRCT + BLKS'TRNSFRD;                    <<04578>>11260000
                                                               <<04578>>11262000
   <<*******************************************************>> <<04578>>11264000
   << Calculate/obtain number of records transfered.  CHK-  >> <<04578>>11266000
   << VARBLK calculated num. of records for variable files. >> <<04578>>11268000
   <<*******************************************************>> <<04578>>11270000
                                                               <<04578>>11272000
   IF ACB'VARIABLE THEN                                                 11274000
      BEGIN                                                             11276000
      ACB'BLK := BLKS'TRNSFRD + ACB'BLK;                       <<04578>>11278000
      IF ACB'MSGFILE THEN                                      <<HM.00>>11280000
         FCUPDATEWRITE(ACBMQ,NONDATARECORDS);                  <<HM.00>>11282000
      RECS'TRNSFRD := NUM'VAR'RECS; << # of recs, this xfer >> <<04578>>11284000
      END                                                               11286000
   ELSE                                                                 11288000
      BEGIN          << non-variable >>                                 11290000
      << Calculate the # of recs xfered, fixed or undef.    >> <<04578>>11292000
      RECS'TRNSFRD := BLKS'TRNSFRD * DBLKFACT;                 <<04578>>11294000
      END;                                                              11296000
                                                               <<04578>>11298000
   <<*******************************************************>> <<04578>>11300000
   << Update record transfer count, file pointer and TARGET >> <<04578>>11302000
   << address and word count.                               >> <<04578>>11304000
   <<*******************************************************>> <<04578>>11306000
                                                               <<04578>>11308000
   ACB'FPTR := RECS'TRNSFRD + ACB'FPTR;                        <<04578>>11310000
   ACB'RTFRCT := RECS'TRNSFRD + ACB'RTFRCT;                    <<04578>>11312000
   @TARGET := @TARGET+WTT;       << update target addr. >>              11314000
   WC := WC-WTT;                 << update word count >>                11316000
                                                               <<04578>>11318000
   <<*******************************************************>> <<04578>>11320000
   << If we are writing more than one blocks worth to a     >> <<04578>>11322000
   << file, then one of two things can happen.  If there is >> <<04578>>11324000
   << room  left  in  the extent (then  the file was not    >> <<04578>>11326000
   << streamed), then WRITE'MORE'IN'EXTENT. Otherwise, write>> <<04578>>11328000
   << more in the next extent. For device files, just do    >> <<04578>>11330000
   << another ATTACHIO to the device.                       >> <<04578>>11332000
   <<*******************************************************>> <<04578>>11334000
                                                               <<04578>>11336000
   IF ACB'ACCCL=DIRACC THEN                                             11338000
      BEGIN                                                             11340000
      SECTS'TRNSFRD := (WTT'L + 127) / 128;                    <<04578>>11342000
      STX := STX - SECTS'TRNSFRD;                              <<04578>>11344000
      << Update disc address for next block read.           >> <<04578>>11346000
      DISKADR := DISKADR + DBL(SECTS'TRNSFRD);                 <<04578>>11348000
      IF STX > 0 AND WC > 0 THEN                                        11350000
         BEGIN   << Xfer was limited by block size. >>         <<01690>>11352000
         IF WTT > WC THEN WTT := WC;   << last xfer is short >>         11354000
         GO WRITE'MORE'IN'EXTENT;                              <<04578>>11356000
         END;                                                           11358000
      IF WC > 0 THEN                                           <<01690>>11360000
         BEGIN      << Transfer more in next extent. >>        <<01690>>11362000
         FSET'EOF(ACB'FPTR);    << for FCLEAR in FCONV'BLK >>  <<01690>>11364000
         GO WLOOP;                                             <<01690>>11366000
         END;                                                  <<01690>>11368000
      END;                                                              11370000
   IF WC > 0 THEN GO WLOOP;                                             11372000
                                                                        11374000
   <<*******************************************************>> <<04578>>11376000
   << Covert EOFDELTA to records and update EOF, subtracing >> <<04578>>11378000
   << EOFDELTA to account for partial block write.  Clear   >> <<04578>>11380000
   << remaining sectors in the block for partial write.     >> <<04578>>11382000
   <<*******************************************************>> <<04578>>11384000
                                                               <<04578>>11386000
                                                                        11388000
   IF ACB'ACCCL=DIRACC THEN                                             11390000
      BEGIN         << check for EOF advanced >>                        11392000
      IF EOFDELTA <> 0 THEN EOFDELTA := BLKFACT-                        11394000
         (EOFDELTA+RSIZE-1)/RSIZE;    << records to end of blk >>       11396000
      IF < THEN EOFDELTA := 0;                                          11398000
      FSET'EOF(ACB'FPTR-DOUBLE(EOFDELTA));                              11400000
      IF NEWEOF THEN   << Did EOF advance into new block? >>            11402000
         BEGIN     << Yes. Clear partial block >>                       11404000
         SECTS'TO'FILL := ACB'BSIZE/128-(WTT+127)/128;         <<04578>>11406000
         IF > THEN                                                      11408000
            BEGIN          << partial block >>                          11410000
                                                               <<04450>>11412000
            << Want to clear all RIO files with zeroes to   >> <<04450>>11414000
            << clear the ART.                               >> <<04450>>11416000
                                                               <<04450>>11418000
            IF ACB'RIO OR (NOT ACB'ASCII)                      <<04578>>11420000
               THEN CLEARTYPE := FALSE    << Clear with 0's >> <<04578>>11422000
               ELSE CLEARTYPE := TRUE;    << Blanks.        >> <<04578>>11424000
            X := FCLEAR(CLEARTYPE,LDEV,DISKADR,SECTS'TO'FILL); <<04578>>11426000
                                                               <<04578>>11428000
$  IF X1 = ON                                                           11430000
            IF <> THEN FTROUBLE(478);  << error >>                      11432000
$  IF                                                                   11434000
            END;                                                        11436000
         END;        << EOF advanced >>                                 11438000
      END;     << check for EOF advanced >>                             11440000
   END;   << write request >>                                           11442000
                                                                        11444000
      END       << Unbuffered >>                                        11446000
   ELSE                                                                 11448000
$PAGE " IOMOVE - BUFFERED "                                             11450000
      BEGIN                                                             11452000
                                                                        11454000
<< ******* Buffered ******* >>                                          11456000
                                                                        11458000
                                                                        11460000
   <<* * * Init. parameters and check request * * *>>                   11462000
                                                                        11464000
   ACB'TLOG := 0;                                                       11466000
   ACB'ERROR := 0;                                                      11468000
   ACB'STATUS := 0;                                                     11470000
   IF ACB'FPTR < 0D THEN ERREXIT(BADRECNO);                    <<02068>>11472000
   IF ACB'SPECVAR THEN                                                  11474000
      BEGIN        << Special variable format. >>                       11476000
      MODES := IF MODE >= MIN'MODE'FDEVICECONTROL              <<04321>>11478000
               THEN MODE ELSE MODE.(13:3);                     <<04321>>11480000
      MODE.(13:3) := IF MODES <> 0 THEN 1 ELSE 0;                       11482000
      BLK'OVERHEAD := 8;     << block overhead (bytes) >>      <<04578>>11484000
      REC'OVERHEAD := 8;     << record overhead (bytes) >>     <<04578>>11486000
      END                                                               11488000
   ELSE                                                                 11490000
      BEGIN        << Not special variable. >>                          11492000
      MODE.(13:2) := 0;         << no-op >>                             11494000
      MODES := MODE.(15:1);                                             11496000
      BLK'OVERHEAD := 4;                                       <<04578>>11498000
      REC'OVERHEAD := 0;                                       <<04578>>11500000
      END;                                                              11502000
   MR := IF ACB'SPOOLED THEN ACB'SPAOPT.AOPMULTIRECF                    11504000
      ELSE ACB'MULTIREC;  << Buffered MR for spooling only.  >>         11506000
   NUM'BUFS := ACB'NUMBUFS+1;   << number of buffers >>        <<04566>>11508000
                                                               <<04578>>11510000
   <<*******************************************************>> <<04578>>11512000
   << For labeled tape and serial disc only, ATTIOFLAGS sig->> <<04578>>11514000
   << nify to do WAIT FOR I/O for all buffered I/O.  For all>> <<04578>>11516000
   << other files, ATTIOFLAGS signify to do NOWAIT I/O for  >> <<04578>>11518000
   << all buffers.  The top 4 bits are equal to 1 to signi- >> <<04578>>11520000
   << by that the request is from the file system.          >> <<04578>>11522000
   <<*******************************************************>> <<04578>>11524000
                                                               <<04578>>11526000
   ATTIOFLAGS := IF ACB'DTYPE=SDISC OR LABEL'DEVICE            <<03582>>11528000
      THEN BFLAGS ELSE UFLAGS;                                          11530000
                                                                        11532000
   <<*******************************************************>> <<04578>>11534000
   << MRLOOP is used when writing MR to a spoolfile.  We    >> <<04578>>11536000
   << break the write into record size pieces and continue  >> <<04578>>11538000
   << to write until done.  This is how a spoolfile can be  >> <<04578>>11540000
   << written MR, even though it is a buffered file.        >> <<04578>>11542000
   <<*******************************************************>> <<04578>>11544000
                                                               <<04578>>11546000
MRLOOP:                                                                 11548000
   IF READ THEN                                                         11550000
                                                                        11552000
   <<*******************************************************>> <<04578>>11554000
   <<              BUFFERED READ REQUEST                    >> <<04578>>11556000
   << First, determine if we are attempting to read beyond  >> <<04578>>11558000
   << the current end of file pointer.                      >> <<04578>>11560000
   <<*******************************************************>> <<04578>>11562000
                                                                        11564000
RIOREAD:                                                                11566000
   BEGIN                                                                11568000
   IF ACB'ACCCL = DIRACC AND ACB'FPTR >= FSET'EOF(0D) THEN     <<01910>>11570000
      BEGIN           << Report EOF. >>                                 11572000
      ACB'EOF := 1;                                                     11576000
      ACB'STATUS := EOFCODE;                                   <<01910>>11578000
      ACB'ERROR := EOF;                                        <<01910>>11580000
      IF RIO'ACTIVE'MODE THEN ACB'ERROR := INACT;              <<04592>>11582000
      GO EXIT;                                                 <<01910>>11584000
      END;                                                              11586000
                                                                        11588000
   <<*******************************************************>> <<04578>>11590000
   << Truncate the read request to the files record size if >> <<04578>>11592000
   << greater.  For normal variable, the next record will   >> <<04578>>11594000
   << determine how much we are reading.                    >> <<04578>>11596000
   <<*******************************************************>> <<04578>>11598000
                                                               <<04578>>11600000
   IF NOT ACB'VARIABLE THEN                                             11602000
      BEGIN           << Non-variable record format >>                  11604000
      IF BC > ACB'RSIZE THEN                                            11606000
         BC := ACB'RSIZE;  << Truncate request to rec. size >>          11608000
      END                                                               11610000
   ELSE                                                                 11612000
      BEGIN           << Variable length records >>                     11614000
      IF ACB'SPOOLED AND                                                11616000
          BC > (ACB'SPREC+ACB'SPFOPT.FOPCONTROLF) THEN                  11618000
         BC := ACB'SPREC;                                               11620000
      END;                                                              11622000
   BC'TRAIL'FILL := 0;                                         <<04578>>11624000
                                                                        11626000
   <<*******************************************************>> <<04566>>11628000
   << Search buffers for block to be read.  If we're lucky, >> <<04566>>11630000
   << it is already in (or coming into) a buffer from a pre->> <<04566>>11632000
   << read or prior read or write to the block.  Start pre- >> <<04566>>11634000
   << reads on all empty buffers on the first FREAD after   >> <<04566>>11636000
   << opening the file starting at the block we need.  For  >> <<04566>>11638000
   << each block with I/O pending, perform a don't wait for >> <<04566>>11640000
   << I/O on it.  This will free needed DRQ entries and pre->> <<04566>>11642000
   << vent potential sytem hangs caused by running out of   >> <<04566>>11644000
   << DRQ entries due to the way we do no-wait I/O.         >> <<04566>>11646000
   <<*******************************************************>> <<04566>>11648000
                                                                        11650000
   BLK'IN    := NOT'FOUND; << Clear block found flag        >> <<04566>>11652000
   BUF'EMPTY := NOT'FOUND; << Clear empty buffer flag.      >> <<04566>>11654000
   I := ACB'CURRBUF;       << Current buffer number.        >> <<04566>>11656000
   DO << For each and every buffer for the file.            >> <<04566>>11658000
      BEGIN                                                    <<04566>>11660000
      GETBLKPARMS;                                             <<04566>>11662000
      IF BLOCK = BLK'BLOCK                                     <<04566>>11664000
         THEN BLK'IN := I  << We found the needed block!    >> <<04566>>11666000
      ELSE IF BLK'BLOCK = EMPTY AND FREAD'MODE AND NOT ACB'EOF <<04592>>11668000
         THEN STARTREAD(ACB'HIBLK+1D) << Pre-read on blk.   >> <<04566>>11670000
      ELSE IF BLK'IOPEND AND ACB'ACCCL = DIRACC                <<04590>>11672000
         THEN DONT'WAYT;              << Clear DRQ entry    >> <<04590>>11674000
                                                               <<04566>>11676000
      IF BLOCK = BLK'BLOCK                                     <<04566>>11678000
         THEN BLK'IN := I  << Pre-read found the needed blk.>> <<04566>>11680000
      ELSE IF BLK'BLOCK = EMPTY AND BLK'IN = NOT'FOUND AND     <<04566>>11682000
              BUF'EMPTY = NOT'FOUND                            <<04566>>11684000
         THEN BUF'EMPTY := I;  << Use 1st. empty buffer.    >> <<04566>>11686000
                                                               <<04566>>11688000
      I := (I + 1) MOD NUM'BUFS;                               <<04566>>11690000
      END                                                      <<04566>>11692000
   UNTIL I = ACB'CURRBUF;                                      <<04566>>11694000
                                                                        11696000
                                                               <<04563>>11698000
   <<*******************************************************>> <<04563>>11700000
   << If the block that we need is not already in a buffer, >> <<04563>>11702000
   << then use an empty buffer.  If there are no empty buf- >> <<04563>>11704000
   << fers, then use the next buffer after the current,     >> <<04563>>11706000
   << writing out the old block first if dirty.             >> <<04563>>11708000
   <<*******************************************************>> <<04563>>11710000
                                                               <<04563>>11712000
   IF BLK'IN = NOT'FOUND THEN                                  <<04563>>11714000
      BEGIN                   << Block is not in buffers.   >> <<04563>>11716000
      IF BUF'EMPTY = NOT'FOUND THEN << Empty buffer avail?  >> <<04590>>11718000
         BEGIN                                                 <<04590>>11720000
         IF DIRECT'ACCESS                                      <<04590>>11722000
            THEN I := (ACB'CURRBUF + 1) MOD NUM'BUFS           <<04590>>11724000
            ELSE I := ACB'CURRBUF;                             <<04590>>11726000
         END                                                   <<04590>>11728000
      ELSE                                                     <<04590>>11730000
         I := BUF'EMPTY;       << Empty  buffer             >> <<04590>>11732000
      GETBLKPARMS;                                             <<04563>>11734000
      IF BLK'IOCOMP = 2                                        <<04563>>11736000
         THEN STARTWRITE;     << Write out dirty block.     >> <<04563>>11738000
      IF BLK'IOPEND                                            <<04563>>11740000
         THEN WAYT(0);        << Complete I/O of buffer.    >> <<04563>>11742000
      STARTREAD(BLOCK);       << Begin to read buffer in.   >> <<04563>>11744000
      END                                                      <<04563>>11746000
   ELSE                                                        <<04563>>11748000
      BEGIN                   << Block is in buffers.       >> <<04563>>11750000
      I := BLK'IN;                                             <<04563>>11752000
      GETBLKPARMS;                                             <<04563>>11754000
      END;                                                     <<04563>>11756000
                                                                        11758000
   <<*******************************************************>> <<04578>>11760000
   << We now have the block that we need in buffer # I,     >> <<04578>>11762000
   << wait for it to come in if I/O pending on the block.   >> <<04578>>11764000
   <<*******************************************************>> <<04578>>11766000
                                                                        11768000
GBK:                                                                    11770000
   ACB'CURRBUF := I;          << Current buffer nr. >>                  11772000
   IF FREADSEEK'MODE THEN GO SETX;                             <<04592>>11774000
   IF BLK'IOPEND THEN                                          <<04590>>11776000
      FINISHREAD(TRUE)      << Wait for I/O, check stat.    >> <<04590>>11778000
   ELSE IF BLK'DONTWAIT THEN                                   <<04590>>11780000
      FINISHREAD(FALSE);    << Dont Wait comp., check stat. >> <<04590>>11782000
                                                                        11784000
   <<*******************************************************>> <<04578>>11786000
   <<   #### RIO ####    #### RIO ####    #### RIO ####     >> <<04578>>11788000
   <<*******************************************************>> <<04578>>11790000
                                                                        11792000
   IF ACB'RIO THEN                                                      11794000
      BEGIN                                                             11796000
                                                               <<04578>>11798000
      <<****************************************************>> <<04578>>11800000
      << For FREADDIR, return an error if the current rec-  >> <<04578>>11802000
      << ord is not active, but still return the record.    >> <<04578>>11804000
      <<****************************************************>> <<04578>>11806000
                                                               <<04578>>11808000
      IF FREADDIR'MODE THEN                                    <<04592>>11810000
         BEGIN             << FREADDIR >>                               11812000
         TOS := GETARTWORD;                                             11814000
         ASMB(TBC 0,X);                                                 11816000
         IF = THEN ACB'ERROR := INACT;                                  11818000
         END                                                            11820000
                                                               <<04578>>11822000
      <<****************************************************>> <<04578>>11824000
      << For FREAD, find the first active record.  If non-  >> <<04578>>11826000
      << available in the current block, then increment the >> <<04578>>11828000
      << BLOCK number and try the next block.               >> <<04578>>11830000
      <<****************************************************>> <<04578>>11832000
                                                               <<04578>>11834000
      ELSE IF FREAD'MODE THEN                                  <<04592>>11836000
         BEGIN             << FREAD >>                                  11838000
SRCH:    TOS := GETARTWORD;                                             11840000
         TOS := TOS LAND (-1)&LSR(X);                                   11842000
         ASMB(SCAN);         << find first act. rec. >>                 11844000
         DEL;                                                           11846000
         RXB := RXB.(0:12)&LSL(4)+X;                                    11848000
         IF X = 16 THEN                                                 11850000
            BEGIN     << No active record in this bitmap. >>            11852000
            IF RXB < BLKFACT THEN GO SRCH;                              11854000
            REC'PNTR := RXB := 0; << No active recs. in blk.>> <<04578>>11856000
            BLOCK := BLOCK+1D;                                          11858000
            ACB'FPTR := BLOCK*DBLKFACT;                                 11860000
            GO RIOREAD;      << try next block. >>                      11862000
            END                                                         11864000
         ELSE                                                           11866000
                                                               <<04578>>11868000
            <<**********************************************>> <<04578>>11870000
            << Found an active record, set file pointer and >> <<04578>>11872000
            << buffer record pointer.                       >> <<04578>>11874000
            <<**********************************************>> <<04578>>11876000
                                                               <<04578>>11878000
            BEGIN       << Got a live one. >>                           11880000
            ACB'FPTR := BLOCK*DBLKFACT+DOUBLE(RXB);                     11882000
            REC'PNTR := RXB*RSIZE;                             <<04578>>11884000
            END                                                         11886000
         END          << FREAD >>                                       11888000
                                                               <<04578>>11890000
      <<****************************************************>> <<04578>>11892000
      << For FDELETE, deactivate the record and exit.       >> <<04578>>11894000
      <<****************************************************>> <<04578>>11896000
                                                               <<04578>>11898000
      ELSE IF RIO'DELETE'MODE THEN                             <<04592>>11900000
         BEGIN             << FDELETE >>                                11902000
         TOS := GETARTWORD;                                             11904000
         ASMB(TRBC 0,X);    << de-activate record >>                    11906000
         IF <> THEN PUTARTWORD(*) ELSE ACB'ERROR := INACT;              11908000
         ACB'STATUS := 1;    << return CCE >>                           11910000
         GO PEXIT                                                       11912000
         END                                                            11914000
                                                               <<04578>>11916000
      <<****************************************************>> <<04578>>11918000
      << Check active state of current record and return.   >> <<04578>>11920000
      <<****************************************************>> <<04578>>11922000
                                                               <<04578>>11924000
      ELSE IF RIO'ACTIVE'MODE THEN                             <<04592>>11926000
         BEGIN     << return activity state >>                          11928000
         TOS := GETARTWORD;                                             11930000
         ASMB(TBC 0,X);                                                 11932000
         IF = THEN ACB'ERROR := INACT;                                  11934000
         GO EXIT;                                                       11936000
         END;                                                           11938000
      END;          << RIO >>                                           11940000
                                                                        11942000
   <<*******************************************************>> <<04578>>11944000
   << For variable length records, deblock the record.  Jump>> <<04578>>11946000
   << to the next block if end of block flag is found in the>> <<04578>>11948000
   << byte count.  Check for bad variable block structure.  >> <<04578>>11950000
   <<*******************************************************>> <<04578>>11952000
                                                                        11954000
   BC'DATA'REC := ACB'RSIZE;      << data chars in record >>   <<04578>>11956000
   IF ACB'VARIABLE THEN                                                 11958000
      BEGIN         << Variable read request >>                         11960000
      GET2WORDS;     << fetch char cnts to T1-T2 >>                     11962000
      BC'DATA'REC := T1;            << rec char cnt >>         <<04578>>11964000
      IF BC'DATA'REC = -1 THEN                                 <<04578>>11966000
         BEGIN  << Block has no data records. Flush it. >>     <<01898>>11968000
         BLOCK := ACB'BLK := ACB'BLK+1D;                       <<01898>>11970000
         GO RIOREAD;                                           <<01750>>11972000
         END;                                                  <<01750>>11974000
      REC'PNTR := REC'PNTR + 1;  << Skip over byte count    >> <<04578>>11976000
      IF BC'DATA'REC < 0 OR                                    <<04578>>11978000
         BC'DATA'REC >= (ACB'BSIZE-REC'PNTR)*2 THEN            <<04578>>11980000
         ERREXIT(BADVARBLK);                                            11982000
                                                               <<04578>>11984000
      <<****************************************************>> <<04578>>11986000
      << For spoolfile records, determine the actual size of>> <<04578>>11988000
      << the data portion and determine the amount of trail->> <<04578>>11990000
      << ing fill needed to fill at the end of the record.  >> <<04578>>11992000
      << Also, REC'PNTR is updated to point past header.    >> <<04578>>11994000
      <<****************************************************>> <<04578>>11996000
                                                               <<04578>>11998000
      IF ACB'SPECVAR THEN                                               12000000
         BEGIN      << T2 is original record char count. >>             12002000
         BC'DATA'REC := BC'DATA'REC - REC'OVERHEAD;            <<04578>>12004000
         IF NOT ACB'SPOOLED OR ACB'SPFOPT.FOPFORMATF <> 0 THEN          12006000
            IF BC > T2 THEN BC := T2;  << reduce large request >>       12008000
         IF BC > BC'DATA'REC                                   <<04578>>12010000
            THEN BC'TRAIL'FILL := BC - BC'DATA'REC;            <<04578>>12012000
         REC'PNTR := REC'PNTR + REC'OVERHEAD/2;                <<04606>>12014000
         END;         << special variable >>                            12016000
      IF BC > BC'DATA'REC                                      <<04578>>12018000
         THEN BC := BC'DATA'REC;  << Reduce large request.  >> <<04578>>12020000
                                                               <<04578>>12022000
      <<****************************************************>> <<04578>>12024000
      << MOVE spoolfile record's trailing fill into the     >> <<04578>>12026000
      << users target buffer.                               >> <<04578>>12028000
      <<****************************************************>> <<04578>>12030000
                                                               <<04578>>12032000
      IF BC'TRAIL'FILL > 0 THEN                                <<04578>>12034000
         BEGIN        << Regenerate trailing fill characters >>         12036000
         TOS := @TARGET*2 + BC'DATA'REC; << byte address >>    <<04578>>12038000
         ASMB(DUP,INCB);                                                12040000
         BPS0 := FILL;                                                  12042000
         MOVE * := * ,(BC'TRAIL'FILL-1);                       <<04578>>12044000
         END                                                            12046000
      END      << variable read request >>                              12048000
                                                                        12050000
   <<*******************************************************>> <<04578>>12052000
   << For undefined files, determine byte count of record   >> <<04578>>12054000
   << from block transmission log.                          >> <<04578>>12056000
   <<*******************************************************>> <<04578>>12058000
                                                               <<04578>>12060000
   ELSE IF ACB'UNDEFINED THEN                                           12062000
      BEGIN          << "Undefined" record format >>                    12064000
      IF BLK'TLOG < 0                                          <<04578>>12066000
         THEN BC'DATA'REC := \BLK'TLOG\   << Positive bytes >> <<04578>>12068000
         ELSE BC'DATA'REC := BLK'TLOG * 2;                     <<04578>>12070000
      IF BC > BC'DATA'REC                                      <<04578>>12072000
         THEN BC := BC'DATA'REC;   << Block was short.      >> <<04578>>12074000
      END;                                                              12076000
                                                                        12078000
   <<*******************************************************>> <<04578>>12080000
   << Check for logical EOF.  ACB'CTL specifies nature of   >> <<04578>>12082000
   << caller and what kind of EOF he expects.  See FREAD    >> <<04578>>12084000
   << for more details.                                     >> <<04578>>12086000
   <<*******************************************************>> <<04578>>12088000
                                                                        12090000
   GET2WORDS;             << fetch first 2 words to T1-T2 >>            12092000
   IF ACB'CTL.(11:1) THEN                                               12094000
      BEGIN            << Non-CI job or session. >>                     12096000
      IF BC'DATA'REC > 0 THEN                                  <<04578>>12098000
         BEGIN                                                          12100000
         IF BC'DATA'REC >= 4 AND (LT1 LAND %177737) = ":E"     <<04578>>12102000
             AND (LT2 LAND %157737) = "OD" THEN                         12104000
            BEGIN          << Super colon >>                            12106000
                         << EOF both $STDIN & $STDINX >>       <<04578>>12108000
            ACB'EOFS := %(2)11;                                <<04578>>12110000
            ACB'EOF := 1;                                               12112000
            ACB'STATUS := EOFCODE;                                      12114000
            ACB'ERROR := EOF;                                           12116000
            BC := 0;     << for 0 TLOG >>                      <<01790>>12118000
            GO XCOMP                                                    12120000
            END;                                                        12122000
                                                                        12124000
         <<*************************************************>> <<04565>>12126000
         << If encountering a ":" on input, then set EOF. If>> <<04565>>12128000
         << reading more than one byte, then leave the file >> <<04565>>12130000
         << pointer as it is for the next read.  Otherwise, >> <<04565>>12132000
         << continue as if a complete read.                 >> <<04565>>12134000
         <<*************************************************>> <<04565>>12136000
                                                               <<04565>>12138000
         IF NOT ACB'CTL AND (T1.(0:8) = ":") THEN                       12140000
            BEGIN       << ":" on $STDIN >>                             12142000
                         << EOF on $STDIN >>                   <<04578>>12144000
            ACB'EOFS := 1 LOR ACB'EOFS;                        <<04578>>12146000
            ACB'EOF := 1;                                               12148000
            ACB'STATUS := EOFCODE;                                      12150000
            ACB'ERROR := EOF;                                           12152000
            IF BC'DATA'REC > 1                                 <<04578>>12154000
               THEN GO PEXIT;  << Leave file pointer alone. >> <<04565>>12156000
            BC := 0;                                           <<01790>>12158000
            GO XCOMP                                                    12160000
            END                                                         12162000
         END                                                            12164000
      END;     << non-CI job or session >>                              12166000
                                                               <<04578>>12168000
   <<*******************************************************>> <<04578>>12170000
   << Set up MDS parameters for data transfer from ACB buf- >> <<04578>>12172000
   << fer to users buffer.                                  >> <<04578>>12174000
   <<*******************************************************>> <<04578>>12176000
                                                                        12178000
   TOS := DSTX;     << User buffer DST nr. >>                           12180000
   IF = THEN                                                            12182000
      BEGIN         << User buffer in his stack. >>                     12184000
      TOS := TOS+STKDST;      << Stack DST nr. >>                       12186000
      TOS := @TARGET+DBOFST;   << segment-relative buffer addr >>       12188000
      END                                                               12190000
   ELSE          << User buffer in his extra data segment. >>           12192000
      TOS := @TARGET;         << user buffer DST-rel offset >>          12194000
   TOS := BUFDST;             << ACB buffer DST nr. >>                  12196000
   TOS := BUFDISP+REC'PNTR;    << ACB buf locn >>              <<04578>>12198000
   TOS := (BC+1)&LSR(1);      << word count >>                          12200000
                                                                        12202000
   <<*******************************************************>> <<04578>>12204000
   << Save the last word of the users buffer in case we need>> <<04578>>12206000
   << to deal with an odd byte count.                       >> <<04578>>12208000
   <<*******************************************************>> <<04578>>12210000
                                                                        12212000
   X := S0-1;                                                           12214000
   T3 := TARGET(X);                                                     12216000
                                                                        12218000
   <<*******************************************************>> <<04578>>12220000
   << Deblock data from ACB buffer to user's buffer.        >> <<04578>>12222000
   <<*******************************************************>> <<04578>>12224000
                                                                        12226000
   MOVE'DS'5;             << Move to user's buffer >>                   12228000
                                                                        12230000
   <<*******************************************************>> <<04578>>12232000
   << Handle odd byte read.  Restore the extra byte in the  >> <<04578>>12234000
   << user's buffer.                                        >> <<04578>>12236000
   <<*******************************************************>> <<04578>>12238000
                                                                        12240000
   IF LOGICAL(BC) THEN TARGET(X).(8:8) := T3;                           12242000
   ACB'STATUS := 1;    << Set to OK I/O status >>              <<01720>>12244000
                                                               <<01720>>12246000
XCOMP:                                                         <<01720>>12248000
                                                               <<04578>>12250000
   <<*******************************************************>> <<04578>>12252000
   << Update record pointer to point past record that was   >> <<04578>>12254000
   << just read in.                                         >> <<04578>>12256000
   <<*******************************************************>> <<04578>>12258000
                                                               <<04578>>12260000
   REC'PNTR := REC'PNTR + (BC'DATA'REC +1)/2;                  <<04578>>12262000
                                                                        12264000
   <<*******************************************************>> <<04578>>12266000
   << If we are reading the last record in the block, then  >> <<04578>>12268000
   << reuse the buffer, flushing it out first if it was dir->> <<04578>>12270000
   << ty and doing an anticipitory read of the next block   >> <<04578>>12272000
   << into the buffer.                                      >> <<04578>>12274000
   <<*******************************************************>> <<04578>>12276000
                                                               <<04578>>12278000
                                                                        12280000
   GET2WORDS;          << only need one, actually >>                    12282000
   IF MODE = %20 AND                                           <<01698>>12284000
       (REC'PNTR >= BLK'TLOG) OR ACB'UNDEFINED OR              <<04578>>12286000
       ACB'VARIABLE AND T1 = -1 THEN                                    12288000
      BEGIN      << Re-use the buffer - anticipatory read. >>           12290000
      ACB'CURRBUF := (ACB'CURRBUF + 1) MOD NUM'BUFS;           <<04590>>12292000
      IF BLK'IOCOMP = 2 THEN                                            12294000
         BEGIN          << old buffer dirty; write it out. >>           12296000
         STARTWRITE;                                                    12298000
         WAYT(0);                                                       12300000
         END;                                                           12302000
      IF NOT ACB'EOF THEN STARTREAD(ACB'HIBLK+1D);                      12304000
      IF ACB'VARIABLE THEN                                              12306000
         BEGIN     << Insure start at block boundary >>                 12308000
         ACB'BLK := ACB'BLK+1D;                                         12310000
         REC'PNTR := 0;                                        <<04578>>12312000
         END                                                            12314000
      ELSE                                                              12316000
         ACB'FPTR := (BLOCK+1D)*DBLKFACT-1D;                            12318000
      END         << re-use the buffer >>                               12320000
   END        << of read request >>                                     12322000
$PAGE                                                          <<04578>>12324000
   ELSE                                                                 12326000
   BEGIN                                                                12328000
                                                                        12330000
<<* * * *  Buffered WRITE request  * * * *>>                            12332000
                                                                        12334000
   IMBED := ACB'CARRIAGE LAND MODES=1 LAND (ACB'CTL <> 1);              12336000
   BC'TRAIL'FILL := 0;                                         <<04578>>12338000
                                                               <<04578>>12340000
   <<*******************************************************>> <<04578>>12342000
   << For fixed and undefined disc files, check if we are   >> <<04578>>12344000
   << attempting to write past the file limit.              >> <<04578>>12346000
   <<*******************************************************>> <<04578>>12348000
                                                               <<04578>>12350000
   IF NOT ACB'VARIABLE THEN                                             12352000
      BEGIN          << Non-variable record format >>                   12354000
      IF ACB'ACCCL=DIRACC AND ACB'FCB <> 0 AND                 <<01672>>12356000
         ACB'FPTR >= GETFCB'INFO(ACB'FCB,XFLIM)                <<01961>>12358000
          AND NOT ACB'CIRFILE THEN GO ATFLIM;                  <<01961>>12360000
      IF (BC+CCTL) > ACB'RSIZE THEN                            <<04560>>12362000
         BEGIN     << Specified byte count > max. record size. >>       12364000
         IF NOT MR THEN ERREXIT(BADTCOUNT);                             12366000
         BC := ACB'RSIZE-CCTL    << Truncate request >>        <<04560>>12368000
         END                                                            12370000
      END           << non-variable >>                                  12372000
   ELSE                                                                 12374000
                                                               <<04578>>12376000
      <<****************************************************>> <<04578>>12378000
      << If we are appending to a variable length file,     >> <<04578>>12380000
      << FINDFILEND sets REC'PNTR to point past the last    >> <<04578>>12382000
      << record in the file.  The last block number was set >> <<04578>>12384000
      << when opening the file in SETACB.                   >> <<04578>>12386000
      <<****************************************************>> <<04578>>12388000
                                                               <<04578>>12390000
      BEGIN          << Variable length records >>                      12392000
      IF ACB'RTFRCT = 0D AND ACB'FPTR <> 0D THEN FINDFILEND;   <<HM.00>>12394000
                                                               <<04578>>12396000
      <<****************************************************>> <<04578>>12398000
      << Check for oversized variable writes.               >> <<04578>>12400000
      << For spoolfiles, the FORMS message sent with the    >> <<04813>>12402000
      << spoolfile FOPEN mode may be larger than the record >> <<04813>>12404000
      << size specified.  Also, FDEVICECONTROL writes may   >> <<04813>>12406000
      << also be larger than the record size.               >> <<04813>>12408000
      <<****************************************************>> <<04578>>12410000
                                                               <<04578>>12412000
      IF ACB'SPOOLED AND                                                12414000
         BC > (ACB'SPREC+ACB'SPFOPT.FOPCONTROLF) AND           <<04813>>12416000
         NOT FOPEN'MODE THEN                                   <<04813>>12418000
         BEGIN               << Oversize spoolout request. >>           12420000
         IF NOT MR THEN ERREXIT(BADTCOUNT);                             12422000
         BC := ACB'SPREC                                                12424000
         END;                                                           12426000
      IF BC > (ACB'RSIZE-BLK'OVERHEAD-REC'OVERHEAD-CCTL) THEN  <<04813>>12428000
         BEGIN          << Oversize request. >>                         12432000
         IF NOT MR THEN ERREXIT(BADTCOUNT);                             12434000
         BC := ACB'RSIZE-BLK'OVERHEAD-REC'OVERHEAD-CCTL;       <<04578>>12436000
         END;                                                           12438000
      END;            << variable length records >>                     12440000
$PAGE                                                          <<04578>>12442000
   <<*******************************************************>> <<04578>>12444000
   << For a special variable write, we truncate all trailing>> <<04578>>12446000
   << blanks and do not transfer these blanks to the spool- >> <<04578>>12448000
   << file.  However, we save how many blanks we truncated  >> <<04578>>12450000
   << for the special spoolfile byte count located in the   >> <<04578>>12452000
   << spoolfile record header.                              >> <<04578>>12454000
   <<*******************************************************>> <<04578>>12456000
                                                                        12458000
   IF ACB'SPECVAR AND (BC > 1) AND ACB'ASCII AND                        12460000
       (ACB'LINECTL = 0) AND (ACB'CTL <> %320) THEN                     12462000
      BEGIN         << Genuine transfer >>                              12464000
      BC'TRAIL'FILL := BC;                                     <<04578>>12466000
      TOS := @TARGET&LSL(1)+BC-1;                                       12468000
      IF BPS0 = BYTE(FILL.(8:8)) THEN                                   12470000
         BEGIN        << Truncate trailing fill chars. >>               12472000
         ASMB(DUP,DECB);                                                12474000
         IF * <> * ,(2-BC),0 THEN TOS := -TOS;                          12476000
         BC := TOS+1;       << nr. chars remaining >>                   12478000
         DEL                << discard source addr >>                   12480000
         END;                                                           12482000
      DEL;            << discard byte pointer or target addr >>         12484000
      BC'TRAIL'FILL := BC'TRAIL'FILL - BC;                     <<04578>>12486000
      END;          << genuine transfer >>                              12488000
                                                                        12490000
   <<*******************************************************>> <<04578>>12492000
   << Check to see if the variable length record to write   >> <<04578>>12494000
   << will fit in the current block.  If not, flush the     >> <<04578>>12496000
   << buffer and advance the block variables.               >> <<04578>>12498000
   <<*******************************************************>> <<04578>>12500000
                                                               <<04578>>12502000
   IF ACB'VARIABLE THEN                                                 12504000
      BEGIN     << Variable record; check for fit. >>                   12506000
      T1 := REC'PNTR + (BC+BLK'OVERHEAD+REC'OVERHEAD+CCTL+1)/2;<<04578>>12508000
      IF T1 > DATASIZE THEN                                    <<04578>>12510000
         BEGIN      << Oops! New record won't fit in block. >>          12512000
         I := ACB'CURRBUF;     << Current buffer nr. >>                 12514000
         GETBLKPARMS;                                                   12516000
         ACB'CURRBUF := (ACB'CURRBUF + 1) MOD NUM'BUFS;        <<04590>>12518000
         IF BLK'IOCOMP = 2 THEN STARTWRITE;   << write if dirty >>      12520000
         ACB'BLK := BLOCK := BLOCK+1D;                         <<02049>>12522000
         ACB'BUFUSED := 0;                                     <<04592>>12526000
         REC'PNTR := 0;   << init. record pointer >>           <<04578>>12528000
         END;                                                           12530000
      END;     << variable >>                                           12532000
                                                                        12534000
                                                                        12536000
   <<*******************************************************>> <<04566>>12538000
   << Search buffers for correct block or for an empty      >> <<04566>>12540000
   << buffer to use.  Do no wait I/O on all buffers with    >> <<04566>>12542000
   << I/O pending to free valuable DRQ entries.             >> <<04566>>12544000
   <<*******************************************************>> <<04566>>12546000
                                                               <<04566>>12548000
   BLK'IN := NOT'FOUND;        << Clear block in flag.      >> <<04566>>12550000
   BUF'EMPTY := NOT'FOUND;     << Clear empty buf. fnd flag >> <<04566>>12552000
                                                                        12554000
   I := ACB'CURRBUF;     << Current buffer nr. >>                       12556000
   DO BEGIN                                                             12558000
      GETBLKPARMS;                                                      12560000
                                                               <<04590>>12562000
      <<****************************************************>> <<04590>>12564000
      << If the block we want is in, indicate so and call   >> <<04590>>12566000
      << WAYT if I/O pending to wait for block.  If a DONT' >> <<04590>>12568000
      << WAYT completed the I/O for the block, then check   >> <<04590>>12570000
      << the status for it now.                             >> <<04590>>12572000
      <<****************************************************>> <<04590>>12574000
                                                               <<04590>>12576000
      IF BLOCK = BLK'BLOCK THEN                                         12578000
         BEGIN    << Buffer has (or will have) correct block. >>        12580000
         IF BLK'IOPEND AND WAYT(1) THEN                        <<04590>>12582000
            GO PEXIT                                           <<04590>>12584000
         ELSE IF BLK'DONTWAIT THEN                             <<04590>>12586000
            BEGIN  << Dont Wait completion, check status.   >> <<04590>>12588000
            BLK'DONTWAIT := 0;                                 <<04590>>12590000
            IF BLK'LSTAT <> 1 THEN                             <<04590>>12592000
               BEGIN  << An error occured on a pre-read.    >> <<04590>>12594000
               ACB'STATUS := BLK'LSTAT;                        <<04590>>12596000
               ACB'ERROR  := IOSTAT(ACB'STATUS);               <<04590>>12598000
               GO PEXIT;                                       <<04590>>12600000
               END;                                            <<04590>>12602000
            END;                                               <<04590>>12604000
         BLK'IN := I;          << Buffer has our block!     >> <<04566>>12606000
         END                                                   <<04566>>12608000
      ELSE IF BLK'IOPEND AND ACB'ACCCL = DIRACC                <<04590>>12610000
        THEN DONT'WAYT         << Check if I/O completed.   >> <<04590>>12612000
      ELSE IF BLK'BLOCK = EMPTY AND BLK'IN = NOT'FOUND AND     <<04566>>12614000
              BUF'EMPTY = NOT'FOUND                            <<04566>>12616000
        THEN BUF'EMPTY := I;   << Use 1st. empty buffer.    >> <<04566>>12618000
      I := (I+1) MOD NUM'BUFS     << next block >>             <<04566>>12620000
      END                                                      <<04566>>12622000
   UNTIL I = ACB'CURRBUF;                                      <<04566>>12624000
                                                                        12626000
   <<*******************************************************>> <<04563>>12628000
   << If no buffer contains the needed block, then use an   >> <<04563>>12630000
   << empty buffer.  If none available, use the next buffer >> <<04563>>12632000
   << after the current  and bring in the needed block      >> <<04563>>12634000
   << into that buffer, writing it out first if dirty.      >> <<04563>>12636000
   <<*******************************************************>> <<04563>>12638000
                                                               <<04563>>12640000
   IF BLK'IN = NOT'FOUND THEN                                  <<04563>>12642000
      BEGIN                   << Block is not in any buffer >> <<04563>>12644000
      IF BUF'EMPTY = NOT'FOUND THEN << Empty buffer avail?  >> <<04590>>12646000
         BEGIN                                                 <<04590>>12648000
         IF DIRECT'ACCESS                                      <<04590>>12650000
            THEN I := (ACB'CURRBUF + 1) MOD NUM'BUFS           <<04590>>12652000
            ELSE I := ACB'CURRBUF;                             <<04590>>12654000
         END                                                   <<04590>>12656000
      ELSE                                                     <<04590>>12658000
         I := BUF'EMPTY;       << Empty  buffer             >> <<04590>>12660000
      GETBLKPARMS;                                             <<04563>>12662000
      IF BLK'IOCOMP = 2                                        <<04563>>12664000
         THEN STARTWRITE;     << Write out dirty buffer     >> <<04563>>12666000
      IF BLK'IOPEND AND WAYT(BLK'IOOUT)                        <<04563>>12668000
         THEN GO PEXIT;       << Report I/O error on block  >> <<04563>>12670000
      END                                                      <<04563>>12672000
   ELSE                                                        <<04563>>12674000
                                                               <<04625>>12676000
      <<****************************************************>> <<04625>>12678000
      << Otherwise, the block is already in the buffer.  If,>> <<04625>>12680000
      << by some small chance the block was from a read of  >> <<04625>>12682000
      << an unallocated extent, then call FCONV'BLK to al-  >> <<04625>>12684000
      << locate the extent.  Otherwise, skip the initiali-  >> <<04625>>12686000
      << zation stuff and complete the write.               >> <<04625>>12688000
      <<****************************************************>> <<04625>>12690000
                                                               <<04625>>12692000
      BEGIN                                                    <<04625>>12694000
      I := BLK'IN;                                             <<04625>>12696000
      GETBLKPARMS;                                             <<04625>>12698000
      IF NOT BLK'UNALLOCEXT                                    <<04625>>12700000
         THEN GO BLOCKW;      << Block is ready for write.  >> <<04625>>12702000
      END;                                                     <<04563>>12704000
                                                                        12706000
   <<*******************************************************>> <<04578>>12708000
   << Buffer is now empty and set for a new block.  If only >> <<04578>>12710000
   << one record per block, then we only need to post the   >> <<04578>>12712000
   << new block number and block disc address.              >> <<04578>>12714000
   <<*******************************************************>> <<04578>>12716000
                                                                        12718000
   IF ACB'CIRFILE AND LOG(ACB'CIROVERFLOW) THEN                <<HM.00>>12720000
      ADJUSTCIRFILE;                                           <<HM.00>>12722000
   BLK'BLOCK := -1D;     << Denote buffer empty >>             <<02049>>12724000
   BLK'FLAGS := 0;            << Nothing doing! Start fresh.>> <<04625>>12726000
   IF ACB'ACCCL = DIRACC THEN                                           12728000
      BEGIN      << Disk >>                                             12730000
      FCONV'BLK(BLOCK,ACBMQ,MODE,0,0D,0D,0);                   <<04653>>12732000
      BLK'EXTSIZE := TOS;  << Save current extent size      >> <<04653>>12734000
      BLK'EXTBASE := TOS;  << Save current extent base      >> <<04653>>12736000
      FCEOF := TOS;                                                     12738000
      DEL;        << STX >>                                             12740000
      X := TOS;     << Error nr. >>                                     12742000
      IF <> THEN                                                        12744000
         BEGIN      << Some kind of error. >>                           12746000
         IF X = 1 THEN NEWEOF := TRUE   << Beyond prior EOF >>          12748000
         ELSE IF X = 2 THEN                                    <<HM.00>>12750000
            BEGIN     << Beyond file limit >>                  <<02072>>12752000
            IF ACB'CIRFILE THEN                                <<HM.00>>12754000
               BEGIN    << delete the first block >>           <<02072>>12756000
               ASMB(DEL,DDEL);                                 <<HM.00>>12758000
               ACB'CIROVERFLOW := 1;  << for future writes >>  <<02072>>12760000
               ADJUSTCIRFILE;                                  <<HM.00>>12762000
               FCONV'BLK(BLOCK,ACBMQ,1,0,0D,0D,0);             <<04653>>12766000
               BLK'EXTSIZE := TOS;<< Save curr. extent size.>> <<04653>>12768000
               BLK'EXTBASE := TOS;<< Save curr. extent base.>> <<04653>>12770000
               FCEOF := TOS; DEL; X := TOS;                    <<02072>>12772000
               IF X > 2 THEN                                   <<HM.00>>12774000
                  BEGIN    << file error >>                    <<02072>>12776000
                  ACB'ERROR := X;                              <<02072>>12778000
                  ACB'STATUS := 0;                             <<02072>>12780000
                  GO PEXIT;                                    <<HM.00>>12782000
                  END;                                         <<HM.00>>12784000
               END                                             <<HM.00>>12786000
            ELSE                                               <<HM.00>>12788000
               BEGIN       << Beyond file limit >>             <<HM.00>>12790000
               ACB'ERROR := EOF;                               <<HM.00>>12792000
               ACB'STATUS := EOFCODE;                          <<HM.00>>12794000
               ACB'EOF := 1;                                   <<HM.00>>12796000
               GO PEXIT                                        <<HM.00>>12798000
               END;                                            <<HM.00>>12800000
            END                                                <<HM.00>>12802000
         ELSE                                                           12804000
            BEGIN       << Other error >>                               12806000
            ACB'ERROR := X;   << Report error nr. >>                    12808000
            ACB'STATUS := 0;  << Clear I/O error nr. >>                 12810000
            GO PEXIT                                                    12812000
            END                                                         12814000
         END;      << some kind of error >>                             12816000
      LDEV := TOS;      << LDEV of requested record/block >>            12818000
      DISKADR := DS1;   << Sector number for ATTACHIO >>                12820000
      BS1 := LDEV;      << Logical device nr. >>                        12822000
      BLK'DADDR := TOS;                                        <<02049>>12824000
      IF WRITE'EOF'MODE THEN GO PEXIT;                         <<04592>>12826000
                                                               <<04578>>12828000
      <<****************************************************>> <<04578>>12830000
      << If the blocking factor is greater than 1, then the >> <<04578>>12832000
      << block needs to be cleared if we havn't been in it  >> <<04578>>12834000
      << before (if we are writing beyond the current EOF). >> <<04578>>12836000
      <<****************************************************>> <<04578>>12838000
                                                               <<04578>>12840000
      IF BLKFACT > 1  << or RIO? >> THEN                                12842000
         BEGIN         << check for new block >>                        12844000
         IF NEWEOF THEN     << Beyond EOF block? >>                     12846000
            BEGIN   << Yes, start new block. Initialize buffer >>       12848000
            T1 := FILL;                                                 12850000
            TOS := BUFDST;     << dest. is ACB buff addr >>             12852000
            TOS := BUFDISP;                                             12854000
            TOS := T1ADR;                                               12856000
            TOS := 1;                                                   12858000
            MOVE'DS'3;           << put fill in ACB buffer >>           12860000
            ASMB(DDUP,DECA);                                            12862000
            TOS := DATASIZE-1;   << words left to fill >>               12864000
            MOVE'DS'5;           << propagate fill word >>              12866000
                                                                        12868000
            IF ACB'RIO THEN                                             12870000
               BEGIN   << Clear Active Record Table >>         <<00630>>12872000
               T1 := 0;                                                 12874000
               TOS := BUFDST;     << dest. is ACB buff addr >>          12876000
               TOS := BUFDISP+DATASIZE;                                 12878000
               TOS := T1ADR;                                            12880000
               TOS := 1;                                                12882000
               MOVE'DS'3;           << put fill in ACB buffer >>        12884000
               ASMB(DDUP,DECA);                                         12886000
               TOS := ACB'BSIZE-DATASIZE-1;   << words left to fill >>  12888000
               MOVE'DS'5;           << propagate fill word >>           12890000
               END;                                            <<00630>>12892000
            IF BLOCK > ACB'HIBLK THEN ACB'HIBLK := BLOCK;               12894000
            ASMB(DZRO,INCA); TOS := ACB'BSIZE;                          12896000
            BLK'IOCB := TOS;      <<Pseudo IOCB=OK, blk size>>          12898000
            BLK'IOQX := TOS       <<Pseudo IOQX=0>>                     12900000
            END       << start new block >>                             12902000
                                                               <<04578>>12904000
         <<*************************************************>> <<04578>>12906000
         << Otherwise, we are accessing an old block.  Read >> <<04578>>12908000
         << the block into the ACB buffer.                  >> <<04578>>12910000
         <<*************************************************>> <<04578>>12912000
                                                               <<04578>>12914000
         ELSE          << Add to old block >>                           12916000
            BEGIN      << Read block to be modified. >>                 12918000
            << Stack EXTENT parameter information for ATTACHIO <<04653>>12920000
            << and indicate probable access type in FLAGS word <<04653>>12922000
            IF FWRITE'MODE                                     <<04653>>12924000
               THEN FLAGS := BFLAGS CAT BUF'SEQ (0:12:4)       <<04653>>12926000
               ELSE FLAGS := BFLAGS CAT BUF'DIR (0:12:4);      <<04653>>12928000
            TOS := BLK'EXTBASE;                                <<04653>>12930000
            TOS := BLK'EXTSIZE;                                <<04653>>12932000
            BLK'IOCB := ATTACHIO(LDEV,0,BUFDST,BUFDISP,0,               12934000
                 ACB'BSIZE,P1,P2,FLAGS);                       <<04653>>12936000
            << Remove the EXTENT parms on TOS               >> <<04653>>12938000
            ASMB(DDEL,DEL);                                    <<04653>>12940000
            IF BLK'LSTAT <> 1 THEN                                      12942000
               BEGIN            << Read error. >>                       12944000
               ACB'STATUS := BLK'LSTAT;                                 12946000
               ACB'ERROR := IOSTAT(ACB'STATUS);                         12948000
               GO PEXIT                                                 12950000
               END;                                                     12952000
            BLK'FLAGS := 0;    << Denote read completed >>              12954000
            END   << read block to be modified >>                       12956000
         END;    << check for new block >>                              12958000
      END;   << Disk >>                                                 12960000
   BLK'BLOCK := BLOCK;      << It's been validated >>          <<02049>>12962000
                                                               <<04578>>12964000
   <<*******************************************************>> <<04578>>12966000
   << For spoolfile records, place special record pointer   >> <<04578>>12968000
   << into the last two words of the spoolfile block.  This >> <<04578>>12970000
   << is done so that the blocks can be easily scanned to   >> <<04578>>12972000
   << find a particular spoolfile record number.            >> <<04578>>12974000
   <<*******************************************************>> <<04578>>12976000
                                                               <<04578>>12978000
   IF ACB'SPECVAR THEN                                                  12980000
      BEGIN         << Put record number at end. >>                     12982000
      DT1T2 := ACB'FPTR;                                                12984000
      TOS := BUFDST;                                                    12986000
      TOS := BUFDISP+ACB'BSIZE-2;                                       12988000
      TOS := T1ADR;                                                     12990000
      TOS := 2;                                                         12992000
      MOVE'DS'5;                                                        12994000
      END;                                                              12996000
                                                                        12998000
   <<*******************************************************>> <<04578>>13000000
   << The needed block is now in the buffer.  Move the rec- >> <<04578>>13002000
   << cord from the ACB buffer into the users buffer. The   >> <<04578>>13004000
   << ACB buffer address (DST and displacement) is on TOS   >> <<04578>>13006000
   << for most of what follows.                             >> <<04578>>13008000
   <<*******************************************************>> <<04578>>13010000
                                                               <<04578>>13012000
                                                                        13014000
BLOCKW:                                                                 13016000
   IF WRITE'EOF'MODE THEN GO PEXIT;                            <<04592>>13018000
   TOS := BUFDST;        << Set ACB buff dest addr >>                   13020000
   TOS := BUFDISP+REC'PNTR;                                    <<04578>>13022000
                                                                        13024000
   <<*******************************************************>> <<04578>>13026000
   << Prepare and post byte counts for variable file.       >> <<04578>>13028000
   << For spoolfiles, we must set up the special record,    >> <<04578>>13030000
   << with both byte counts and the ATTACHIO parameters.    >> <<04578>>13032000
   <<*******************************************************>> <<04578>>13034000
                                                               <<04578>>13036000
                                                                        13038000
   IF ACB'VARIABLE THEN                                                 13040000
      BEGIN                                                             13042000
      TOS := T1ADR;                                                     13044000
      T1 := BC+REC'OVERHEAD+CCTL; << Insert rec char cnt. >>   <<04578>>13046000
      IF ACB'SPECVAR THEN                                               13048000
         BEGIN        << Special variable format >>                     13050000
         T2 := BC+BC'TRAIL'FILL + CCTL;  << orig. char cnt.>>  <<04593>>13052000
         T3 := MODES;                << spool control >>                13054000
         T4 := IF IMBED THEN 1 ELSE ACB'CTL;  << P1 >>                  13056000
         TOS := ACB'LPCTL;                                              13058000
         TOS.(12:1) := NOT ACB'ASCII;                                   13060000
         T5 := TOS;                        << P2 >>                     13062000
         IF MODES >= MIN'MODE'FDEVICECONTROL THEN              <<04321>>13064000
            DT4T5 := ACB'X1X2;    << Kluge for FDEVICECONTROL >>        13066000
         TOS := 5;                                                      13068000
         END   << special variable >>                                   13070000
      ELSE                                                              13072000
         TOS := 1;                                                      13074000
      REC'PNTR := REC'PNTR + S0; << Skip over header.          <<04578>>13076000
      MOVE'DS'3;   << leave ACB buf addr on TOS >>                      13078000
      END;       << variable >>                                         13082000
                                                                        13084000
   <<*******************************************************>> <<04578>>13086000
   << Now, set the current buffer number and declare the    >> <<04578>>13088000
   << block to be "dirty".                                  >> <<04578>>13090000
   <<*******************************************************>> <<04578>>13092000
                                                               <<04578>>13094000
   ACB'CURRBUF := I;    << Set current buffer nr. >>                    13096000
   BLK'DIRTY := 1;      << Set buffer modified flag >>                  13098000
                                                                        13100000
   <<* * * Get parameters for data transfer * * *>>                     13102000
                                                                        13104000
   TOS := DSTX;      << User buffer DST nr. >>                          13106000
   IF = THEN         << User buffer in his stack? >>                    13108000
      BEGIN         << Fetch stack DB value from PCBX(1) >>             13110000
      TOS := TOS+STKDST;    << Stack DST nr. >>                         13112000
      TOS := @TARGET+DBOFST   << segment-relative buffer address >>     13114000
      END                                                               13116000
   ELSE          << User buffer in his extra data segment >>            13118000
      TOS := @TARGET;    << user buffer offset >>                       13120000
                                                                        13122000
   <<*******************************************************>> <<04578>>13124000
   << Now move the data from the users buffer to the ACB    >> <<04578>>13126000
   << buffer.                                               >> <<04578>>13128000
   <<*******************************************************>> <<04578>>13130000
                                                                        13132000
   TOS := (BC+1)&LSR(1);  << Total word count >>                        13134000
   T1 := TARGET(S0-1);    << save last word of u-buff >>                13136000
   IF LOG(BC) THEN TARGET(X).(8:8) := FILL;                             13138000
   MOVE'DS'3;             << Move data from user's buffer >>            13140000
   TARGET(X) := T1;       << restore user's buffer >>                   13142000
                                                                        13144000
   <<*******************************************************>> <<04578>>13146000
   << To imbed the carriage control byte, shift all the data>> <<04578>>13148000
   << in the buffer record one byte right and place CCTL at >> <<04578>>13150000
   << the first byte of the record.                         >> <<04578>>13152000
   <<*******************************************************>> <<04578>>13154000
                                                               <<04578>>13156000
   IF IMBED THEN                                                        13158000
      BEGIN         << Imbed carriage control byte >>                   13160000
      EXCHANGEDB(BUFDST);   << to ACB buffer >>                         13162000
      TOS := S0&LSL(1);     << current byte address >>                  13164000
      IF LOG(BC) THEN TOS := TOS-1   << one byte too far >>             13166000
      ELSE                                                              13168000
         BEGIN                                                          13170000
         S1 := S1+1;    << will be current word posn >>                 13172000
         BPS0(1) := BYTE(FILL);                                         13174000
         END;                                                           13176000
      ASMB(DUP,DECA);                                                   13178000
      MOVE * := *,(-BC),2;  << Shift right one byte >>                  13180000
      BPS0 := ACB'CTL;      << Insert carriage control byte >>          13182000
      DEL;                                                              13184000
      EXCHANGEDB(DSTX)      << back to user's buffer >>                 13186000
      END;       << imbed car control >>                                13188000
                                                                        13190000
   <<*******************************************************>> <<04578>>13192000
   << Place block terminator after record for variable. For >> <<04578>>13194000
   << fixed or undefined, propigate fill characters into the>> <<04578>>13196000
   << record for a write shorter than one record in length. >> <<04578>>13198000
   <<*******************************************************>> <<04578>>13200000
                                                               <<04578>>13202000
   IF ACB'VARIABLE THEN                                                 13204000
      BEGIN   << Put block terminator [-1] after record. >>             13206000
      T1 := -1;                                                         13208000
      TOS := T1ADR;                                                     13210000
      TOS := 1;                                                         13212000
      MOVE'DS'3;                                                        13214000
      END                                                               13216000
   ELSE      << ACB'FIXED Calculate WORD count to propigate.>> <<04560>>13218000
      BEGIN                                                    <<04560>>13220000
      T2 := (ACB'RSIZE+1)/2 - (CCTL+BC+1)/2;                   <<04560>>13222000
                                                               <<04560>>13224000
      IF T2 > 0 THEN                                           <<04560>>13226000
         BEGIN  << Fill short record out to standard size. >>  <<04560>>13228000
         T1 := FILL;                                           <<04560>>13230000
         TOS := T1ADR;                                         <<04560>>13232000
         TOS := 1;                                             <<04560>>13234000
         MOVE'DS'3;        << put fill in ACB buffer >>        <<04560>>13236000
         ASMB(DDUP,DECA);                                      <<04560>>13238000
         TOS := T2-1;      << words left to fill >>            <<04560>>13240000
         MOVE'DS'3;        << propagate fill word >>           <<04560>>13242000
         END;                                                  <<04560>>13244000
      END;                                                     <<04560>>13246000
                                                                        13248000
                                                                        13250000
   <<*******************************************************>> <<04578>>13252000
   << Delete ACB buffer DST and offset off of stack.  Then  >> <<04578>>13254000
   << update buffer record pointer and EOF.                 >> <<04578>>13256000
   <<*******************************************************>> <<04578>>13258000
                                                               <<04578>>13260000
   DDEL;                << Done with ACB buff addr. >>                  13262000
   IF ACB'FIXED                                                <<04578>>13264000
      THEN REC'PNTR := REC'PNTR + (ACB'RSIZE+1)/2              <<04578>>13266000
      ELSE REC'PNTR := REC'PNTR + (BC+CCTL+1)/2;               <<04578>>13268000
   IF ACB'ACCCL=DIRACC THEN FSET'EOF(ACB'FPTR+1D);                      13270000
                                                                        13272000
   <<*******************************************************>> <<04578>>13274000
   << For RIO, activate bit for record written in the ART.  >> <<04578>>13276000
   <<*******************************************************>> <<04578>>13278000
                                                                        13280000
   IF ACB'RIO THEN                                                      13282000
      BEGIN                                                             13284000
      TOS := GETARTWORD;                                                13286000
      ASMB(TSBC 0,X);      << set bit X -- activate >>                  13288000
      PUTARTWORD(*);                                                    13290000
      END;                                                              13292000
                                                                        13294000
   <<*******************************************************>> <<04578>>13296000
   << If we are writing to the last record in the block,    >> <<04578>>13298000
   << then start the write of the block to disc, verifying  >> <<04578>>13300000
   << the write if I/O has completed or the user has re-    >> <<04578>>13302000
   << quested verification of all output (FSETMODE bit 14). >> <<04578>>13304000
   <<*******************************************************>> <<04578>>13306000
                                                               <<04578>>13308000
   IF REC'PNTR >= DATASIZE OR ACB'UNDEFINED THEN               <<04578>>13310000
      BEGIN       << Buffer full; write it out. >>                      13312000
      ACB'CURRBUF := (ACB'CURRBUF + 1) MOD NUM'BUFS;           <<04590>>13314000
      STARTWRITE;                                                       13316000
      IF ACB'QUIESCE OR ATTIOFLAGS THEN                                 13318000
         BEGIN       << Verify output. >>                               13320000
         IF WAYT(1) THEN GO PEXIT  << I/O error. >>                     13322000
         END;                                                           13324000
      END;            << buffer was full >>                             13326000
   ACB'STATUS := 1;      << claim xfer was good >>             <<02071>>13328000
   END;   << of buffered write request >>                               13330000
$PAGE                                                          <<04578>>13332000
   <<*******************************************************>> <<04578>>13334000
   <<                                                       >> <<04578>>13336000
   <<          BUFFERED COMPLETION - READ AND WRITE         >> <<04578>>13338000
   <<                                                       >> <<04578>>13340000
   << Update the ACB transmission log, buffer record poin-  >> <<04578>>13342000
   << ter (used for variable files to keep track of where   >> <<04578>>13344000
   << we are in the block), file record pointer and record  >> <<04578>>13346000
   << transfer count.                                       >> <<04578>>13348000
   <<*******************************************************>> <<04578>>13350000
                                                                        13352000
   IF ACB'VARIABLE THEN BC := BC+BC'TRAIL'FILL;                <<04578>>13354000
   ACB'TLOG := ACB'TLOG+(IF TCOUNT < 0 THEN -BC                         13356000
      ELSE (BC+1)&LSR(1));     << +words or -bytes >>                   13358000
   ACB'BUFUSED := REC'PNTR;                                    <<04578>>13360000
   ACB'FPTR := ACB'FPTR+1D;       << Set file pointer >>                13362000
   ACB'RTFRCT := ACB'RTFRCT+1D;   << Bump transfer count >>             13364000
                                                               <<04578>>13366000
   <<*******************************************************>> <<04578>>13368000
   << If we are writing MR to a spoolfile, then we break the>> <<04578>>13370000
   << write up into record size pieces, continuing to write >> <<04578>>13372000
   << unil done.                                            >> <<04578>>13374000
   <<*******************************************************>> <<04578>>13376000
                                                               <<04578>>13378000
   IF MR THEN                                                           13380000
      BEGIN             << multi-block transfer. >>                     13382000
      @TARGET := @TARGET+(BC+1)&LSR(1);                                 13384000
      BC := TCOUNT-ACB'TLOG;  << Amt. left to do (+W/-B)>>              13386000
      BC := IF TCOUNT < 0 THEN -BC ELSE BC&LSL(1);  << +B >>            13388000
      IF BC <= 0 THEN GO PEXIT;     << MR done. >>                      13390000
      PUTBLKPARMS;                                                      13392000
      GO MRLOOP         << Get next block >>                            13394000
      END;                                                              13396000
                                                                        13398000
   TOS := ACB'SPXDDX;                                                   13400000
   IF <> AND (ACB'FPLOW LAND %77) = 0 THEN                              13402000
      XDDSPOOLINFO(ACB'FPTR,%21,PS0);  << line count >>                 13404000
   DEL;                                                                 13406000
                                                                        13408000
PEXIT:                                                                  13410000
   PUTBLKPARMS;                                                         13412000
   END;   << of buffered I/O >>                                         13414000
                                                                        13416000
EXIT:                                                                   13418000
   IF ACB'ERROR = TAPERREC THEN IF ACB'TAPEERROR THEN          <<02068>>13420000
     ACB'STATUS := PARERRSTAT     << CCL for recov err >>      <<02071>>13422000
      ELSE BEGIN                                               <<02071>>13424000
      ACB'ERROR := 0;      << Ignore recovered tape error. >>           13426000
SETX: ACB'STATUS := 1;                                                  13428000
      END;                                                              13430000
   TOS := ACB'ERROR;                                                    13432000
   SPOOLERRCODE;                                                        13434000
   ACB'ERROR := TOS;                                                    13436000
   END;         << procedure IOMOVE >>                                  13438000
                                                                        13440000
$PAGE " FQUIESCEIO "                                                    13442000
$PAGE                                                          <<04591>>13444000
$CONTROL SEGMENT = FILESYS1A  << FQUIESCE'IO >>                         13446000
INTEGER PROCEDURE FQUIESCE'IO(MODE);                                    13448000
VALUE MODE; LOGICAL MODE;                                               13450000
                                                               <<04591>>13452000
<<**********************************************************>> <<04591>>13454000
<< This procedure completes all outstanding I/O against the >> <<04591>>13456000
<< file specified by the ACB.  If I/O is pending, then a    >> <<04591>>13458000
<< Wait takes place until its completion.  If a buffer is   >> <<04591>>13460000
<< dirty but not written, then it is written.               >> <<04591>>13462000
<<                                                          >> <<04591>>13464000
<<   Input variables:                                       >> <<04591>>13466000
<<       MODE - TRUE if searching for EOF (from tape).      >> <<04591>>13468000
<<              Used for Forward Space File, return when an >> <<04591>>13470000
<<              EOF is found on a pre-read.                 >> <<04591>>13472000
<<                                                          >> <<04591>>13474000
<<   Output variable:                                       >> <<04591>>13476000
<<       FQUIESCE'IO - Number of buffers quiesced.  This is >> <<04591>>13478000
<<                     used in some magnetic tape operations>> <<04591>>13480000
<<                     to concur the logical and physical   >> <<04591>>13482000
<<                     tape positions do to pre-reads. Eg.  >> <<04591>>13484000
<<                     when a Write is performed after any  >> <<04591>>13486000
<<                     number of pre-reads mispositioned the>> <<04591>>13488000
<<                     the head.                            >> <<04591>>13490000
<<                     If MODE is requested and EOF is hit, >> <<04591>>13492000
<<                     then -1 is returned as the value.    >> <<04591>>13494000
<< NOTE:  DB can be set anywhere upon entrance.             >> <<04591>>13496000
<<        The ACB MUST BE AT Q-62!!!!!  Do not stack any    >> <<04591>>13498000
<<        variables before calling this procedure!!!!!!!    >> <<04591>>13500000
<<        Also, use TOS for the return value so that the    >> <<04591>>13502000
<<        compiler does not leave any variables on TOS.     >> <<04591>>13504000
<<**********************************************************>> <<04591>>13506000
                                                               <<04591>>13508000
OPTION PRIVILEGED,UNCALLABLE;                                           13510000
BEGIN                                                                   13512000
   INTEGER ARRAY ACB(*) = Q-62;                                         13514000
   BUILD'ACB;                                                           13516000
   INTEGER ACB'BSIZE    = ACB+9;                                        13518000
   INTEGER ACB'CTL      = ACB+11;                                       13520000
   INTEGER ACB'TLOG     = ACB+15;                                       13522000
   DOUBLE ACB'BLK       = ACB+18;                                       13524000
   DOUBLE ACB'BTFRCT    = ACB+22;                                       13526000
   INTEGER ACB'BUFUSED  = ACB+32;                                       13528000
                                                                        13530000
   INTEGER BUFDST       = ACB+48;     << PACB DST nr. >>                13532000
   INTEGER PACBOFST     = ACB+49;     << DST-rel @PACB >>               13534000
                                                                        13536000
DEFINE                                                                  13538000
   BLK'FLAGS     =BLK'FLAGW.( 8:8)#,                           <<04625>>13540000
   BLK'IOPEND    =BLK'FLAGW.(15:1)#,                           <<01802>>13542000
   BLK'IOCOMP    =BLK'FLAGW.(14:2)#;                                    13544000
                                                                        13546000
   << Current block header image [buffered] at Q+1 >>                   13548000
                                                                        13550000
   INTEGER BLK'IOQX;                                                    13552000
   LOGICAL BLK'FLAGW;                                                   13554000
   DOUBLE BLK'IOCB, BLK'BLOCK, BLK'DADDR;                               13556000
   DOUBLE BLK'EXTBASE;  << EXTENT BASE OF CURRENT BLOCK >>     <<04653>>13558000
   LOGICAL BLK'EXTSIZE; << EXTENT SIZE OF CURRENT BLOCK >>     <<04653>>13560000
   LOGICAL BLK'DUMMY;   << * * CURRENTLY UNUSED * *     >>     <<04653>>13562000
      INTEGER BLK'LSTAT = BLK'IOCB;                                     13564000
      INTEGER BLK'TLOG  = BLK'IOCB+1;                                   13566000
                                                                        13568000
   INTEGER RESULT = FQUIESCE'IO;                                        13570000
   INTEGER I;                                                           13572000
   INTEGER J;            << nr. of buffers >>                           13574000
   INTEGER LDEV;         << LDEV of block >>                            13576000
   DOUBLE DISKADR;       << sector nr. >>                               13578000
   INTEGER P1 = DISKADR;    << sector nr. - first half >>               13580000
   INTEGER P2 = DISKADR+1;  << sector nr. - second half >>              13582000
   INTEGER BUFDISP,FERR;                                       <<04591>>13584000
   DOUBLE BKHDADR;         << DST-rel addr of blk header image >>       13586000
      INTEGER STKDST=BKHDADR;                                           13588000
      INTEGER Q'1'A =BKHDADR+1;                                         13590000
   DOUBLE BLOCK;                                                        13592000
                                                               <<04653>>13594000
<< I/O type information for FLAGS.(0:4) of ATTACHIO >>         <<04653>>13596000
EQUATE BUF'FLUSH = 9;                                          <<04653>>13598000
                                                                        13600000
$  IF X0 = ON                                                           13602000
   IF MONOTHER THEN  << monitoring? >>                                  13604000
      BEGIN                                                             13606000
      FTITLE("FQUI","ESCE","IO  ",0D);                                  13608000
      DEBUG                                                             13610000
      END;                                                              13612000
$  IF                                                                   13614000
                                                                        13616000
   <<* * *  Initialize local variables  * * *>>                         13618000
                                                                        13620000
   IF ACB'MSGFILE THEN RETURN;                                 <<HM.00>>13622000
   STKDST := PCB'STK;                                                   13624000
   PUSH(DL,Q);                                                          13626000
   ASMB(XCH,SUB);            << DL-Q for Q-rel addressing >>            13628000
   ASMB(DUP,STAX);                                                      13630000
   X := TOS-AQM1(X);         << (a-Q) <== (DL-Q) - (DL-a) >>            13632000
   Q'1'A := 1-X;             << 1 - (a-Q) >>                            13634000
   J := ACB'NUMBUFS+1;       << number of buffers >>                    13636000
   << Jump to next buffer past possible pre-read.           >> <<04591>>13638000
   I := ACB'CURRBUF;         << current buffer nr. >>                   13640000
   IF ACB'ACCCL <> DIRACC THEN                                          13642000
      BEGIN                << Not disk. >>                              13644000
      LDEV := ACB'DADDR;     << LDEV of device >>                       13646000
      TOS := ACB'CTL;        << carriage control >>                     13648000
      TOS := ACB'LPCTL;      << line and page control >>                13650000
      TOS.(12:1) := NOT ACB'ASCII;   << ASCII/binary format >>          13652000
      TOS.(13:1) := 1;   << allow tape write past EOT >>       <<02054>>13654000
      P2 := TOS; P1 := TOS;                                             13656000
      ACB'EOF := 0;                                                     13658000
      IF <> THEN ASMB(NOP);     << for bug trap >>                      13660000
      END;                                                              13662000
                                                                        13664000
   <<* * *  Cycle through buffers  * * *>>                              13666000
                                                                        13668000
   DO BEGIN                                                             13670000
      TOS := BKHDADR;                                                   13672000
      TOS := BUFDST;                                                    13674000
      TOS := PACBOFST+SIZEACB+I*(BLKBUFDISP+ACB'BSIZE);                 13676000
      TOS := BLKBUFDISP;     << nr. words in header >>                  13678000
      MOVE'DS'1;   << Copy buffer header to local storage. >>           13680000
      BUFDISP := TOS;    << ACB buffer address >>                       13682000
      ASMB(DDEL,DEL);                                                   13684000
      IF BLK'IOPEND THEN                                       <<01802>>13686000
         BEGIN     << Pending I/O to clean up. >>              <<01802>>13688000
         IF BLK'IOQX <> 0 THEN                                 <<01802>>13690000
            BEGIN         << I/O in progress >>                <<01802>>13692000
            BLK'IOCB := WAITFORIO(BLK'IOQX);  << await complete  SERIO>>13694000
$   IF X1 = ON                                                          13696000
            IF <> THEN FTROUBLE(480);  << error >>             <<01802>>13698000
$   IF                                                                  13700000
            END;                                               <<01802>>13702000
         GO BUMP                                                        13704000
         END                                                            13706000
      ELSE IF BLK'IOCOMP = 2 THEN                                       13708000
         BEGIN    << Buffer dirty and not yet written. >>               13710000
         IF ACB'ACCCL = DIRACC THEN                                     13712000
            BEGIN              << Disk. >>                              13714000
            TOS := 0;          << for LDEV >>                           13716000
            TOS := BLK'DADDR;   << LDEV and sector nr. >>               13718000
            TOS := TOS&TASL(8)&DLSR(8);  << separate >>                 13720000
            DISKADR := TOS;      << sector nr. >>                       13722000
            LDEV := TOS;                                                13724000
            END                                                <<02545>>13726000
         ELSE IF ACB'DTYPE = MTAPE THEN                        <<02652>>13728000
            BEGIN                                              <<02652>>13730000
            BLK'IOCB := WRITE'DENSITY(LDEV);                   <<02652>>13732000
            IF BLK'LSTAT.(8:8) <> 1 THEN                       <<02652>>13734000
               GO BUMP;  << Don't do write.  Report error. >>  <<02652>>13736000
            END;                                               <<02652>>13738000
         << Stack EXTENT parameters for ATTACHIO >>            <<04653>>13740000
         TOS := BLK'EXTBASE;                                   <<04653>>13742000
         TOS := BLK'EXTSIZE;                                   <<04653>>13744000
         BLK'IOCB := ATTACHIO(LDEV,0,BUFDST,BUFDISP,1,         <<01802>>13746000
            IF I = ACB'CURRBUF AND ACB'ACCCL <> DIRACC THEN             13748000
               ACB'BUFUSED+(IF ACB'VARIABLE THEN 1 ELSE 0)              13750000
            ELSE                                                        13752000
               ACB'BSIZE,                                               13754000
            P1,P2,BFLAGS CAT BUF'FLUSH (0:12:4)); << BLK wrt >><<04653>>13756000
         << Remove stacked EXTENT parameters >>                <<04653>>13758000
         ASMB(DDEL,DEL);                                       <<04653>>13760000
BUMP:    BLK'IOQX := 0;        << clear IOQX >>                <<01802>>13762000
         ACB'TLOG := BLK'TLOG;  << set transmission log >>              13764000
         ACB'STATUS := BLK'LSTAT;                              <<00483>>13766000
         IF ACB'STATUS = 1 THEN                                         13768000
            ACB'BTFRCT := ACB'BTFRCT+1D << OK: bump count >>   <<00483>>13770000
         ELSE                                                  <<04591>>13772000
            BEGIN                                              <<04591>>13774000
            FERR := IOSTAT(ACB'STATUS);                        <<04591>>13776000
            IF FERR = EOF                                      <<04591>>13778000
               THEN ACB'EOF := 1                               <<04591>>13780000
               ELSE ACB'ERROR := FERR; << other error >>       <<04591>>13782000
            END;                                               <<04591>>13784000
                                                               <<04591>>13786000
         <<*************************************************>> <<04591>>13788000
         << Do not report a pre-read if labeled and EOF hit >> <<04591>>13790000
         << since, when it was originally hit, tape labels  >> <<04591>>13792000
         << backspaced over the EOF, so we don't have to    >> <<04591>>13794000
         << back space over it again.                       >> <<04591>>13796000
         <<*************************************************>> <<04591>>13798000
                                                               <<04591>>13800000
         IF NOT(ACB'LABELLED LAND ACB'EOF)                     <<04591>>13802000
            THEN RESULT := RESULT+1;                           <<04591>>13804000
         END;           << buffer dirty >>                              13806000
      BLOCK := BLK'BLOCK;                                               13808000
      BLK'BLOCK := -1D;     << Mark buffer empty >>                     13810000
      BLK'FLAGS  := 0;                                         <<04590>>13812000
      TOS := BUFDST;                                                    13814000
      TOS := PACBOFST+SIZEACB+I*(BLKBUFDISP+ACB'BSIZE);                 13816000
      TOS := BKHDADR;                                                   13818000
      TOS := BLKBUFDISP;     << nr. words in header >>                  13820000
      MOVE'DS'5;          << Post updated block header to PACB. >>      13822000
      I := (I+1) MOD J;    << Advance buffer >>                         13824000
      IF MODE AND ACB'EOF THEN                                          13826000
         BEGIN      << Mag tape FSF; got EOF on preread. >>             13828000
         ACB'FPTR := (BLOCK+1D)*DOUBLE(ACB'BLKFACT);                    13830000
         ACB'CURRBUF := I;                                              13832000
         FQUIESCE'IO := -1;                                             13834000
         ACB'EOF := 0;                                                  13836000
         RETURN;                                                        13838000
         END;                                                           13840000
      END UNTIL I = ACB'CURRBUF;                                        13842000
   IF ACB'ACCCL <> DIRACC THEN                                 <<04141>>13844000
      BEGIN << Future writes must be to new block >>           <<04141>>13846000
      ACB'BLK := ACB'BLK + 1D;                                 <<04141>>13848000
      IF ACB'VARIABLE THEN ACB'BUFUSED := 0                    <<04141>>13850000
      ELSE ACB'FPTR := (BLOCK+1D)*DOUBLE(ACB'BLKFACT);         <<04141>>13852000
      END;                                                     <<04141>>13854000
                                                               <<04141>>13856000
   END;     << procedure FQUIESCE'IO >>                                 13858000
$PAGE "  IOWAIT SUB-PROCEDURES "                                        13860000
$ CONTROL SEGMENT = FILESYS2  << GET'CS'IOQINDICES >>                   13862000
                                                                        13864000
INTEGER PROCEDURE GET'CS'IOQINDICES(CSMDST,IOQ'VECTOR,         <<00613>>13866000
      IOQINDEX'ARRAY);                                                  13868000
VALUE IOQ'VECTOR,CSMDST;                                                13870000
INTEGER IOQ'VECTOR,CSMDST;                                              13872000
INTEGER ARRAY IOQINDEX'ARRAY;                                           13874000
OPTION PRIVILEGED,UNCALLABLE;                                           13876000
   BEGIN                                                                13878000
   << This procedure is used to return all of the IOQ indices           13880000
      associated with a CS AFT entry.  These IOQ indices are            13882000
      recovered from the data segment associated with the AFT           13884000
      "CSMDST", with the pointer being "IOQ'VECTOR".                    13886000
        Input: IOQ'VECTOR - vector to CS IOQ index entries              13888000
                CSMDST - DST number containing IOQ indices              13890000
        Output:  NUM'IOQS - number of IOQ indices                       13892000
             IOQINDEX'ARRAY - array containing the IOQ indices          13894000
      This procedure is also called by CABORTIO in COMSYS1.             13896000
      DB is at the stack.  >>                                           13898000
                                                                        13900000
   EQUATE MAXCBSIZE=15;                                                 13902000
   INTEGER I,NUM'IOQS;                                                  13904000
   INTEGER ARRAY CB(0:MAXCBSIZE);                                       13906000
                                                                        13908000
   TOS := @CB;                                                          13910000
   TOS := CSMDST;                                                       13912000
   TOS := IOQ'VECTOR;                                                   13914000
   TOS := MAXCBSIZE;                                                    13916000
   ASSEMBLE(MFDS);    << copy to local Q-rel array >>                   13918000
<< Move IOQ indices into IOQINDEX array. >>                             13920000
   NUM'IOQS := CB.(8:8) -1;   <<CB size includes zero'th word>>         13922000
   MOVE IOQINDEX'ARRAY := CB(1),(NUM'IOQS);                             13924000
<< Find number of IOQ indices >>                                        13926000
   I := 0;                                                              13928000
   WHILE IOQINDEX'ARRAY(I) <> 0 AND I < NUM'IOQS DO                     13930000
      I := I+1;                                                         13932000
   GET'CS'IOQINDICES := I;                                              13934000
   END;      << procedure GET'CS'IOQINDICES >>                          13936000
$ PAGE                                                                  13938000
PROCEDURE FINDWAITINGIO (IONUMBER,AFT,FLAGS);                           13940000
   << Finds and optionally waits for the first pending No-wait          13942000
     I/O request to complete.                                           13944000
     Input variables:                                                   13946000
         FLAGS - special action flags                                   13948000
            (14:1) - don't wait for I/O completion                      13950000
               0 - impede (wait) if no I/O has completed                13952000
               1 - return IONUMBER = 0 if no I/O has completed          13954000
            (15:1) - special completion checking order                  13956000
               0 - check for I/O completion at LEFTOFF+1                13958000
               1 - check for I/O completion at AFT 1                    13960000
                                                                        13962000
     Output variables:                                                  13964000
         IONUMBER - file/line number of completed I/O                   13966000
         AFT - AFT entry pointer of completed I/O                       13968000
                                                                        13970000
     Condition code:                                                    13972000
         CCE - OK                                                       13974000
         CCL - no I/O pending                                           13976000
                                                                        13978000
     This procedure can be called with DB at any data segment.          13980000
     DB will be at the stack when this procedure returns. >>            13982000
                                                                        13984000
VALUE IONUMBER,AFT,FLAGS;                                               13986000
INTEGER IONUMBER;                                                       13988000
INTEGER POINTER AFT;                                                    13990000
LOGICAL FLAGS;                                                          13992000
OPTION INTERNAL,PRIVILEGED,UNCALLABLE;                                  13994000
   BEGIN                                                                13996000
   DEFINE DONTWAIT = FLAGS.(14:1)#,  <<Don't wait for I/O>>             13998000
          RESET = FLAGS.(15:1)#;    <<Reset LEFTOFF to 0>>              14000000
   DEFINE SET'CCL =BEGIN TOS := -1; DEL; END #;                         14002000
   DEFINE SETS1AFT = TOS:=S1; SETAFT'#;                        <<01817>>14004000
   INTEGER FILENUM = IONUMBER;                                          14006000
   DOUBLE POINTER AFTDBL = AFT;                                         14008000
   EQUATE ENDOFLIST  = %177777;   << stacked info marker >>             14010000
   EQUATE                                                      <<04567>>14012000
      STUB'IOQX = -1;                                          <<04567>>14014000
   INTEGER POINTER PXFILE;        << PXFILE pointer >>                  14016000
   INTEGER LEFTOFF;     << leftoff file/line nr. from PXFILE >>         14018000
   INTEGER NRAFTENTRIES;                                                14020000
   INTEGER IOQX,COMP'IOQINDEX:=0;                              <<02362>>14022000
   LOGICAL ONLYMSGFILE:=TRUE;  <<TRUE IF ONLY WAIT ON MSG FILES  HM.00>>14024000
   EQUATE NO'WAIT'DONE = -1;                                   <<HM.00>>14026000
   EQUATE SOFTINTPEND = -2;                                    <<03038>>14028000
   INTEGER ARRAY IOQINDEX(0:13);                               <<00613>>14030000
   INTEGER I,NUM'IOQINDICES;                                   <<00613>>14032000
   LOGICAL                                                     <<00613>>14034000
      MULTI'CSIOQS, <<set if CS entry has multiple IOQINDICES>><<00613>>14036000
      OUTSTANDING'IOQ; <<set if AFT entry has outstanding I/O>><<00613>>14038000
                                                                        14040000
   SUBROUTINE SETWAKE'(INDEX);                                 <<HM.00>>14042000
   VALUE INDEX;                                                <<HM.00>>14044000
   INTEGER INDEX;                                              <<HM.00>>14046000
      BEGIN                                                    <<HM.00>>14048000
      IF AFTMSGTYPE THEN                                       <<HM.00>>14050000
         BEGIN                                                 <<HM.00>>14052000
         IF INDEX = NO'WAIT'DONE THEN                          <<HM.00>>14054000
            BEGIN  <<IO COMPLETED AT INITAITION TIME>>         <<HM.00>>14056000
            TOS:=-1; DEL;  <<FORCE CCL STATUS>>                <<HM.00>>14058000
            END                                                <<HM.00>>14060000
         ELSE                                                  <<HM.00>>14062000
            FCPORTENABLE(INDEX);                               <<03038>>14064000
         END                                                   <<HM.00>>14066000
      ELSE                                                     <<HM.00>>14068000
         BEGIN                                                 <<HM.00>>14070000
         ONLYMSGFILE:=FALSE;                                   <<HM.00>>14072000
         SETWAKE(INDEX);                                       <<HM.00>>14074000
         END;                                                  <<HM.00>>14076000
      END;  <<SETWAKE'>>                                       <<HM.00>>14078000
   SUBROUTINE CLEARWAKE'(INDEX);                               <<HM.00>>14080000
   VALUE INDEX;                                                <<HM.00>>14082000
   INTEGER INDEX;                                              <<HM.00>>14084000
      BEGIN                                                    <<HM.00>>14086000
      IF AFTMSGTYPE THEN                                       <<HM.00>>14088000
         FCPORTDISABLE(INDEX)                                  <<HM.00>>14090000
      ELSE                                                     <<HM.00>>14092000
         CLEARWAKE(INDEX);                                     <<HM.00>>14094000
      END;  <<CLEARWAKE>>                                      <<HM.00>>14096000
$  IF X0 = ON                                                           14098000
   IF MONOTHER THEN                                                     14100000
      BEGIN                                                             14102000
      FTITLE("FIND","WAIT","INGI","O   ");                              14104000
      DEBUG                                                             14106000
      END;                                                              14108000
$  IF                                                                   14110000
                                                                        14112000
   CONDCODE := CCE;      << assume success >>                           14114000
   IF PCB'STK <> 0 THEN EXCHANGEDB(0);  <<SET DB TO STACK>>    <<HM.00>>14116000
   SETPXFILE;            << init. PXFILE pointer >>                     14118000
   NRAFTENTRIES := PXFAFTSIZE/AFTENTRY;                                 14120000
   IF = THEN GO NFG;      << no files opened?? >>                       14122000
   TOS := PXFLEFTOFF;     << last entry to complete I/O >>              14124000
   IF = OR RESET THEN S0 := NRAFTENTRIES;  << reset LEFTOFF?>>          14126000
   LEFTOFF := TOS;        << last entry to consider >>                  14128000
   CLEARWWS;                                                            14130000
                                                                        14132000
   <<* * * Step thru pending I/O's looking for completed one * * *>>    14134000
                                                                        14136000
TRYAGAIN:                                                               14138000
   IONUMBER := LEFTOFF;    << Init. to last completor >>                14140000
   TOS := ENDOFLIST;    << Mark bottom of stacked info. >>              14142000
   DO BEGIN                                                             14144000
      IONUMBER := (IONUMBER MOD NRAFTENTRIES)+1;  << next entry >>      14146000
      SETAFT;     << init. AFT pointer >>                               14148000
      MULTI'CSIOQS := AFTCSTYPE LAND (AFTCSIOQCBV <> 0);       <<00613>>14150000
      OUTSTANDING'IOQ:=                                        <<03038>>14152000
         IF AFTMSGTYPE AND (AFTIOQX = SOFTINTPEND) THEN FALSE  <<03038>>14154000
          ELSE (AFTIOQX <> 0) LOR MULTI'CSIOQS;                <<03038>>14156000
      IF AFTDBL <> 0D AND AFTDSKLUDGE AND OUTSTANDING'IOQ THEN <<00613>>14158000
         BEGIN                                                 <<00613>>14160000
         IF MULTI'CSIOQS THEN                                  <<00613>>14162000
            BEGIN     << Multiple CS IOQindices out >>         <<00613>>14164000
            NUM'IOQINDICES :=                                  <<00613>>14166000
               GET'CS'IOQINDICES(AFTCS'MDST,AFTCSIOQCBV,       <<00613>>14168000
                     IOQINDEX);                                <<00613>>14170000
            END                                                <<00613>>14172000
         ELSE                                                  <<00613>>14174000
            BEGIN      << AFT has only one IOQindex >>         <<00613>>14176000
            NUM'IOQINDICES := 1;                               <<00613>>14178000
            IOQINDEX := AFTIOQX;                               <<00613>>14180000
            END;                                               <<00613>>14182000
         I := -1;                                              <<00613>>14184000
         WHILE (I := I+1) < NUM'IOQINDICES DO                  <<00613>>14186000
            BEGIN  <<Step thru all IOQindices for this AFT >>  <<00613>>14188000
            IOQX := IOQINDEX(I);                               <<00613>>14190000
                                                               <<04567>>14192000
            <<**********************************************>> <<04567>>14194000
            << If the IOQX found is a -1, then this is a    >> <<04567>>14196000
            << file system stub.  Set CCL to signify that   >> <<04567>>14198000
            << the I/O has completed and return.            >> <<04567>>14200000
            <<**********************************************>> <<04567>>14202000
                                                               <<04567>>14204000
            IF IOQX < 0 AND AFT3270TYPE OR IOQX = STUB'IOQX    <<04567>>14206000
               THEN SET'CCL                                    <<00613>>14208000
               ELSE SETWAKE'(IOQX);                            <<HM.00>>14210000
            IF < THEN                                          <<00613>>14212000
               BEGIN                                           <<00613>>14214000
                                                               <<00613>>14216000
        << I/O has completed; clear Wake bits. >>              <<00613>>14218000
                                                               <<00613>>14220000
               WHILE S0 <> ENDOFLIST DO                        <<00613>>14222000
                  BEGIN      << cleanup >>                     <<00613>>14224000
                  SETS1AFT;                                    <<01817>>14226000
                  CLEARWAKE'(*);  <<CLEAR WAKE BIT>>           <<HM.00>>14228000
                  DEL     << Delete stacked AFT entry nr. >>   <<00613>>14230000
                  END;                                         <<00613>>14232000
               DEL;                                            <<00613>>14234000
                                                               <<00613>>14236000
            <<* * * Return info on completing I/O * * *>>      <<00613>>14238000
                                                               <<00613>>14240000
               SETAFT;                                         <<01817>>14242000
               AFTIOQX := IOQINDEX(I);   <<completed IOQINDEX>><<00613>>14244000
AOK:           PXFLEFTOFF := IONUMBER;<<new LEFTOFF file/line>><<00613>>14246000
               GO EXIT                                         <<00613>>14248000
               END;                                            <<00613>>14250000
            TOS := IONUMBER;  << stack AFT entry nr. >>        <<00613>>14252000
            TOS := IOQX;                                       <<00613>>14254000
            END      << stepping thru IOQindices >>            <<00613>>14256000
         END                                                            14258000
      END UNTIL IONUMBER = LEFTOFF;                                     14260000
                                                                        14262000
<< * * * Wait for completion if there are pending I/O's * * *>>         14264000
                                                                        14266000
   IF S0 <> ENDOFLIST THEN                                              14268000
      BEGIN      << Some AWAKE bits are set.  >>                        14270000
                                                                        14272000
      <<* * * Cleanup if NOWAIT request * * *>>                         14274000
                                                                        14276000
      IF DONTWAIT THEN                                                  14278000
         BEGIN   << Don't wait for completion. Clear Wake bits >>       14280000
         WHILE S0 <> ENDOFLIST DO                                       14282000
            BEGIN        << cleanup >>                                  14284000
            SETS1AFT;                                          <<01817>>14286000
            CLEARWAKE'(*);  <<CLEAR WAKE BIT>>                 <<HM.00>>14288000
            DEL       << delete AFT entry nr. >>                        14290000
            END;                                                        14292000
                                                                        14294000
         <<* * * Return CCE and IONUMBER=0 * * *>>                      14296000
                                                                        14298000
         IONUMBER := 0;  << indicate no I/O completed >>                14300000
         GO EXIT                                                        14302000
         END;                                                           14304000
                                                                        14306000
   << * * * Wait for any pending I/O completion * * *>>                 14308000
                                                                        14310000
      RESETCRITICAL(0);                                        <<HM.00>>14312000
      WAIT(IF ONLYMSGFILE THEN -4 ELSE -%104,%10001);          <<03038>>14314000
      IF > THEN                                                <<03038>>14316000
         BEGIN  <<SOFT INT OCCURRED>>                          <<03038>>14318000
         SETCRITICAL;                                          <<03038>>14320000
         WHILE S0 <> ENDOFLIST DO  <<BACK OUT OF IOQ REQUESTS>><<03038>>14322000
            BEGIN                                              <<03038>>14324000
            SETS1AFT;                                          <<03038>>14326000
            CLEARWAKE'(*);                                     <<03038>>14328000
            DEL;                                               <<03038>>14330000
            END;                                               <<03038>>14332000
         CONDCODE:=CCG;  <<TELL IOWAIT OF SOFT INT>>           <<03038>>14334000
         GO EXIT;                                              <<03038>>14336000
         END;                                                  <<03038>>14338000
      SETCRITICAL;                                             <<HM.00>>14340000
                                                                        14342000
   << * * * Find out which I/O completed * * *>>                        14344000
                                                                        14346000
      DO BEGIN                                                          14348000
         SETS1AFT;                                             <<01848>>14350000
         IOQX := TOS;                                                   14352000
         CLEARWAKE'(IOQX);  <<CLEAR WAKE BIT>>                 <<HM.00>>14354000
         IF < THEN                                             <<02362>>14356000
            BEGIN                                              <<02362>>14358000
              COMP'IOQINDEX := IOQX;                           <<02362>>14360000
              IONUMBER := TOS;                                 <<02362>>14362000
            END                                                <<02362>>14364000
          ELSE DEL;                                            <<02362>>14366000
      END UNTIL S0 = ENDOFLIST;                                <<02362>>14368000
      DEL;                                                     <<02362>>14370000
                                                                        14374000
         << * * * Return info on completing I/O * * *>>                 14376000
      IF COMP'IOQINDEX <> 0 THEN                               <<02362>>14378000
        BEGIN                                                  <<02362>>14380000
            SETAFT;    << init. AFT entry pointer >>                    14382000
            AFTIOQX := COMP'IOQINDEX;                          <<02362>>14384000
            GO AOK                                                      14386000
        END;                                                   <<02362>>14388000
      COMP'IOQINDEX := 0;                                      <<02362>>14392000
      GO TRYAGAIN  << erroneous awakening? >>                           14394000
      END;                                                              14396000
                                                                        14398000
<< * * * Return error since there was no pending I/O * * *>>            14400000
                                                                        14402000
NFG:                                                                    14404000
   PXFLEFTOFF := 0;  << reset Left-off nr. >>                           14406000
   IONUMBER := 0;    << error file/line nr. >>                          14408000
   CONDCODE := CCL;  << error condition code >>                         14410000
                                                                        14412000
EXIT:                                                                   14414000
   RETURN 1                                                    <<+0.02>>14416000
   END;      << procedure FINDWAITINGIO >>                              14418000
$PAGE " COMMAND INTERPRETER SUPPORT "                                   14420000
$CONTROL SEGMENT = FILESYS1A  << FBREAK >>                              14422000
PROCEDURE FBREAK;                                                       14424000
<< Creates a Break mode request queue for the ACB corresponding to      14426000
   $STDIN/$STDLIST.  This procedure is called by the CI on pseudo-      14428000
   interrupt entry from the terminal driver on Break. >>                14430000
                                                                        14432000
OPTION PRIVILEGED,UNCALLABLE;                                           14434000
   BEGIN                                                                14436000
   INTEGER CRIT;     << for SETCRITICAL >>                              14438000
<< Following LOC'ACB params must be in order: >>                        14440000
   INTEGER AFTE;     << AFT entry word 0 >>                             14442000
   INTEGER PACBV;                                                       14444000
   INTEGER LACBV;                                                       14446000
   INTEGER IOQX;                                                        14448000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+6 >>                    14450000
   INTEGER DSTX;      << orig. DST nr. >>                               14452000
                                                                        14454000
$  IF X0 = ON                                                           14456000
   IF MONUNCALLABLE THEN                                                14458000
      BEGIN         << monitoring >>                                    14460000
      FTITLE("FBRE","AK  ",0D,0D);                                      14462000
      DEBUG                                                             14464000
      END;                                                              14466000
$  IF                                                                   14468000
                                                                        14470000
   CRIT := SETCRITICAL;                                                 14472000
   LOC'ACB(*,6,1,%100002);     << get ACB for file 1 >>                 14474000
$  IF X1 = ON                                                           14476000
   IF <> THEN FTROUBLE(481);    << $NULL or error. >>                   14478000
$  IF                                                                   14480000
   ACBBREAK := 1;                                                       14482000
   IF = THEN ACBSAVEEOFS := ACBEOFS;                                    14484000
   UNLOC'ACB(6,0);      << release ACB >>                               14486000
   RESETCRITICAL(CRIT);                                                 14488000
   END;         << procedure FBREAK >>                                  14490000
$CONTROL SEGMENT = FILESYS1A  << FUNBREAK >>                            14492000
PROCEDURE FUNBREAK (ABORT);                                             14494000
   << Destroys the Break mode request queue for the ACB corresponding   14496000
  to $STDIN/$STDLIST.  The request is ignored if not in Break mode.     14498000
                                                                        14500000
     Input variables:                                                   14502000
        ABORT - Broken Re-read flag                                     14504000
           FALSE - Redo Broken Read, if any                             14506000
           TRUE - Abort any Broken Read                                 14508000
                                                                        14510000
  This procedure is used by the CI for ABORT, RESUME, etc. >>           14512000
VALUE ABORT;                                                            14514000
LOGICAL ABORT;                                                          14516000
OPTION PRIVILEGED, UNCALLABLE;                                          14518000
   BEGIN                                                                14520000
   INTEGER CRIT;     << for SETCRITICAL >>                              14522000
<< Following LOC'ACB params must be in order: >>                        14524000
   INTEGER AFTE;     << AFT entry word 0 >>                             14526000
   INTEGER PACBV;                                                       14528000
   INTEGER LACBV;                                                       14530000
   INTEGER IOQX;                                                        14532000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+6 >>                    14534000
   INTEGER DSTX;                                                        14536000
                                                                        14538000
$  IF X0 = ON                                                           14540000
   IF MONUNCALLABLE THEN                                                14542000
      BEGIN        << Monitoring >>                                     14544000
      FTITLE("FUNB","REAK",0D,0D);                                      14546000
      DEBUG                                                             14548000
      END;                                                              14550000
$  IF                                                                   14552000
                                                                        14554000
   CRIT := SETCRITICAL;                                                 14556000
   LOC'ACB(*,6,1,%100000);      << get ACB for file 1 >>                14558000
   IF <> THEN                                                           14560000
      BEGIN       << $NULL or error. >>                                 14562000
      TOS := CCL;                                                       14564000
      GO EXIT                                                           14566000
      END;                                                              14568000
   ACBBREAK := 0;                                                       14570000
   IF <> THEN                                                           14572000
      BEGIN         << Leaving Break mode >>                            14574000
      ACBEOFS := ACBSAVEEOFS;                                           14576000
      ACBABORTREAD := ABORT;  << set Abort Read flag >>                 14578000
                                                                        14580000
<< Tell terminal driver to clear its Break DIT flag                     14582000
   so that the next Read begins with any saved data                     14584000
   already read.  >>                                                    14586000
                                                                        14588000
      ATTACHIO(ACBDADDR,0,0,0,30,0,0,0,BFLAGS);                         14590000
      UNLOC'ACB(6,4);        << Un-break. >>                            14592000
      END                                                               14594000
   ELSE                                                                 14596000
      UNLOC'ACB(6,0);        << release ACB >>                          14598000
   TOS := CCE;                                                          14600000
EXIT:                                                                   14602000
   CONDCODE := TOS;                                                     14604000
   RESETCRITICAL(CRIT);                                                 14606000
   END;        << procedure FUNBREAK >>                                 14608000
$CONTROL SEGMENT = FILESYS1A  << FRESETEOF >>                           14610000
PROCEDURE FRESETEOF;                                                    14612000
   << Clears the EOF flags in the ACB corresponding to                  14614000
    $STDIN/$STDLIST.  This procedure is used by the CI.  >>             14616000
                                                                        14618000
OPTION PRIVILEGED,UNCALLABLE;                                           14620000
   BEGIN                                                                14622000
   INTEGER CRIT;     << for SETCRITICAL>>                               14624000
<< Following LOC'ACB params must be in order: >>                        14626000
   INTEGER AFTE;     << AFT entry word 0 >>                             14628000
   INTEGER PACBV;                                                       14630000
   INTEGER LACBV;                                                       14632000
   INTEGER IOQX;                                                        14634000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+6 >>                    14636000
   INTEGER DSTX;                                                        14638000
                                                                        14640000
$  IF X0 = ON                                                           14642000
   IF MONUNCALLABLE THEN                                                14644000
      BEGIN         << Monitoring >>                                    14646000
      FTITLE("FRES","ETEO","F   ",0D);                                  14648000
      DEBUG                                                             14650000
      END;                                                              14652000
$  IF                                                                   14654000
                                                                        14656000
   CRIT := SETCRITICAL;                                                 14658000
   LOC'ACB(*,6,1,%100000);     << get ACB >>                            14660000
   IF < THEN FTROUBLE(483)    << error >>                               14662000
      ELSE IF > THEN GO OUT;   << $NULL >>                              14664000
   ACBEOFS := 0;       << clear "Global" flags >>                       14666000
   ACBEOF := 0;        << clear "local" flags >>                        14668000
   UNLOC'ACB(6,0);     << release ACB >>                                14670000
OUT:                                                                    14672000
   RESETCRITICAL(CRIT);                                                 14674000
   END;      << procedure FRESETEOF >>                                  14676000
                                                                        14678000
$ CONTROL SEGMENT = FILESYS3   << FGETDISKADR >>                        14680000
DOUBLE PROCEDURE FGETDISKADR(FILENUM,BLKNUM);                           14682000
   << Converts file number and block number into a logical device       14684000
     number and sector number.                                          14686000
                                                                        14688000
     Input variables:                                                   14690000
         FILENUM - file number                                          14692000
         BLKNUM - block number                                          14694000
                                                                        14696000
     Output variables:                                                  14698000
         FGETDISKADR - logical device number and sector number          14700000
            S-1.(0:8)   Logical device number                           14702000
            S-1.(8:8)   Sector number (most significant part)           14704000
            S-0         Sector number (least significant part)          14706000
                                                                        14708000
     Condition code:                                                    14710000
         CCE - OK                                                       14712000
         CCG - Beyond file limit                                        14714000
         CCL - Illegal file nr., $NULL, or not disk file.               14716000
                                                                        14718000
     This procedure is intended primarily for the Loader.  >>           14720000
                                                                        14722000
VALUE FILENUM,BLKNUM;                                                   14724000
INTEGER FILENUM;                                                        14726000
DOUBLE BLKNUM;                                                          14728000
OPTION PRIVILEGED,UNCALLABLE;                                           14730000
   BEGIN                                                                14732000
   INTEGER CRIT;    << for SETCRITICAL>>                                14734000
<< Following LOC'ACB params must be in order: >>                        14736000
   INTEGER AFTE;     << AFT entry word 0 >>                             14738000
   INTEGER PACBV;                                                       14740000
   INTEGER LACBV;                                                       14742000
   INTEGER IOQX;                                                        14744000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+6 >>                    14746000
   INTEGER DSTX;                                                        14748000
EQUATE ACBQ = 6;                                                        14750000
                                                                        14752000
$  IF X0 = ON                                                           14754000
   IF MONUNCALLABLE THEN                                                14756000
      BEGIN                                                             14758000
      FTITLE("FGET","DISK","ADR ",0D);                                  14760000
      DEBUG                                                             14762000
      END;                                                              14764000
$  IF                                                                   14766000
                                                                        14768000
   CRIT := SETCRITICAL;                                                 14770000
   LOC'ACB(*,ACBQ,FILENUM,UMODE);   << get ACB >>                       14772000
   IF <> THEN                                                           14774000
      BEGIN     << Invalid file, or $NULL >>                            14776000
      TOS := CCL;                                                       14778000
      GO EXIT                                                           14780000
      END;                                                              14782000
   IF ACBFCB = 0 THEN                                                   14784000
      BEGIN        << No FCB -- not disk. >>                            14786000
      TOS := CCL;                                                       14788000
      GO ACBERR                                                         14790000
      END;                                                              14792000
   FCONV'BLK(BLKNUM,ACBQ,1,0,0D,0D,0);                         <<04654>>14794000
   ASSEMBLE(DDEL,DEL);  << remove EXTBASE,EXTSIZE >>           <<04653>>14796000
   ASMB(DDEL,DEL);      << discard EOF, STX >>                          14798000
   IF TOS > 1 THEN                                                      14800000
      TOS := CCG     << Beyond FLIM, or other error >>                  14802000
   ELSE                                                                 14804000
      BEGIN          << OK >>                                           14806000
      BS2 := TOS;       << insert LDEV >>                               14808000
      FGETDISKADR := TOS;  << LDEV and sector nr. >>                    14810000
      TOS := CCE                                                        14812000
      END;                                                              14814000
                                                                        14816000
ACBERR:                                                                 14818000
   UNLOC'ACB(ACBQ,0);     << release ACB >>                             14820000
                                                                        14822000
EXIT:                                                                   14824000
   CONDCODE := TOS;     << report condition code >>                     14826000
   RESETCRITICAL(CRIT)                                                  14828000
   END;        << procedure FGETDISKADR >>                              14830000
$ CONTROL SEGMENT = FILESYS3   << FACCESS >>                            14832000
LOGICAL PROCEDURE FACCESS(FILENUM);                                     14834000
   << Returns the access bit list for the specified file.               14836000
                                                                        14838000
     Input variables:                                                   14840000
         FILENUM - file number                                          14842000
                                                                        14844000
     Output variables:                                                  14846000
         FACCESS - access bit list                                      14848000
                                                                        14850000
     Condition code:                                                    14852000
         CCE - OK                                                       14854000
         CCL - Error                                                    14856000
         CCG - File is $NULL                                            14858000
                                                                        14860000
     This procedure is intended primarily for the Loader.   >>          14862000
                                                                        14864000
VALUE FILENUM;                                                          14866000
INTEGER FILENUM;                                                        14868000
OPTION PRIVILEGED,UNCALLABLE;                                           14870000
   BEGIN                                                                14872000
   INTEGER CRIT;     << for SETCRITICAL >>                              14874000
<< Following LOC'ACB params must be in order: >>                        14876000
   INTEGER AFTE;     << AFT entry word 0 >>                             14878000
   INTEGER PACBV;                                                       14880000
   INTEGER LACBV;                                                       14882000
   INTEGER IOQX;                                                        14884000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+6 >>                    14886000
   BUILD'ACB;                                                           14888000
   INTEGER DSTX;                                                        14890000
                                                                        14892000
$  IF X0 = ON                                                           14894000
   IF MONUNCALLABLE THEN                                                14896000
      BEGIN                                                             14898000
      FTITLE("FACC","ESS ",0D,0D);                                      14900000
      DEBUG                                                             14902000
      END;                                                              14904000
$  IF                                                                   14906000
                                                                        14908000
   CRIT := SETCRITICAL;                                                 14910000
   LOC'ACB(*,6,FILENUM,UMODE);   << get ACB >>                          14912000
   IF < THEN                                                            14914000
      BEGIN        << Invalid file nr. >>                               14916000
      TOS := CCL;                                                       14918000
      GO EXIT;                                                          14920000
      HELP; << dummy call >>                                   <<00117>>14922000
      END;                                                              14924000
   IF > THEN                                                            14926000
      BEGIN      << file is $NULL >>                                    14928000
      TOS := CCG;                                                       14930000
      GO EXIT                                                           14932000
      END;                                                              14934000
   IF ACB'ACCCL <> DIRACC THEN                                          14936000
      BEGIN       << Not disk. >>                                       14938000
      TOS := CCL;                                                       14940000
      TOS := DEVVIOL;                                                   14942000
      ACB'ERROR := TOS;                                                 14944000
      GO UNLK                                                           14946000
      END;                                                              14948000
   FACCESS := IF LOGICAL(ACBDOMAIN) THEN ACB'ACCESS ELSE -1;            14950000
   TOS := CCE;     << OK condition code >>                              14952000
                                                                        14954000
UNLK:                                                                   14956000
   UNLOC'ACB(6,0);     << release ACB >>                                14958000
                                                                        14960000
EXIT:                                                                   14962000
   CONDCODE := TOS;    << report condition code >>                      14964000
   RESETCRITICAL(CRIT)                                                  14966000
   END;      << procedure FACCESS >>                                    14968000
$ CONTROL SEGMENT = FILESYS3   << FKSAMBNDVIOL >>                       14970000
PROCEDURE FKSAMBNDVIOL(FILENUM);                               <<KS.00>>14972000
   VALUE FILENUM;                                                       14974000
   INTEGER FILENUM;                                                     14976000
   OPTION PRIVILEGED,UNCALLABLE;                                        14978000
                                                                        14980000
  << This procedure handles KSAM file bounds violations. >>             14982000
   BEGIN                                                                14984000
   INTEGER POINTER AFT;                                                 14986000
   INTEGER USERDB;                                                      14988000
                                                                        14990000
                                                                        14992000
   USERDB := EXCHANGEDB(0);                                             14994000
   SETAFT;                                                              14996000
   AFTFLAG := 3;  << KSAM error >>                                      14998000
   AFTERRNUM := BNDVIOL;                                                15000000
   EXCHANGEDB(USERDB);                                                  15002000
                                                                        15004000
END;                                                                    15006000
$PAGE " FDELETE "                                                       15010000
$CONTROL SEGMENT = FILESYS3  << FDELETE >>                              15012000
                                                                        15014000
PROCEDURE FDELETE(FILENUM,REC);                                <<00630>>15016000
  VALUE FILENUM,REC;                                                    15018000
  INTEGER FILENUM;                                                      15020000
  DOUBLE REC;                                                           15022000
  OPTION VARIABLE,PRIVILEGED;                                           15024000
BEGIN                                                                   15026000
  COMMENT:                                                              15028000
    Deletes the specified RIO record ("REC").  If "REC" is              15030000
    not specified or negative, deletes the next record                  15032000
    (ACBFPTR).  Note that this differs from the COBOL-74                15034000
    definition which has unnatural side-effects.  Thus,                 15036000
    COBOL-74 should always do a random-access FDELETE!                  15038000
    ;                                                                   15040000
                                                                        15042000
                                                                        15044000
  INTEGER CRIT;                                                         15046000
                                                                        15048000
  LOGICAL                                                               15050000
    PARMMASK= Q-4;                                                      15052000
  DEFINE                                                                15054000
    P'REC=     PARMMASK #;                                              15056000
                                                               <<01864>>15058000
<< Remote File Access (RFA) variables.                      >> <<01864>>15060000
                                                               <<01864>>15062000
INTEGER POINTER                                                <<01864>>15064000
  RFAPTR;           << Message array (appendage) pointer.   >> <<01864>>15066000
                                                               <<01864>>15068000
INTEGER                                                        <<01864>>15070000
  RFALEN;           << Length of appendage.                 >> <<01864>>15072000
                                                                        15074000
<< Following LOC'ACB params must be last and in order: >>               15076000
EQUATE ACBMQ =8;                                                        15078000
   INTEGER AFTE;       << AFT entry word 0 >>                           15080000
   INTEGER PACBV;                                                       15082000
   INTEGER LACBV;                                                       15084000
   INTEGER IOQX;                                                        15086000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+6 >>                    15088000
   BUILD'ACB;                                                           15090000
   LOGICAL DSTX;      << DST nr. of user's buffer >>                    15092000
<< end of LOCACB params >>                                              15094000
                                                                        15096000
                                                                        15098000
$ IF X0=ON                                                              15100000
  IF MONCALLABLE THEN                                                   15102000
    BEGIN                                                               15104000
    FTITLE("FDEL","ETE ",0D,0D);                                        15106000
    DEBUG;                                                              15108000
    END;                                                                15110000
$ IF                                                                    15112000
                                                                        15114000
   ERRORON;                                                             15116000
   CRIT := SETCRITICAL;                                                 15118000
                                                                        15120000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<01864>>15122000
   IF < THEN                                                            15124000
      BEGIN      << Invalid file number >>                              15126000
      TOS := INVFN;                                                     15128000
      TOS := CCL;                                                       15130000
      GO EXIT;                                                          15132000
      END;                                                              15134000
   IF > THEN                                                            15136000
      BEGIN    << File is $NULL. >>                                     15138000
      TOS := 0;                                                         15140000
      TOS := CCE;                                                       15142000
      GO EXIT;                                                          15144000
      END;                                                              15146000
                                                                        15148000
   CASE * FTYPE OF                                                      15150000
      BEGIN                                                             15152000
   <<0>> BEGIN    << Conventional file >>                               15154000
         IF NOT ACB'RIO OR ACB'INHIBITBUF THEN                          15156000
            BEGIN                                                       15158000
            TOS := ACCVIOL;                                             15160000
            ACB'ERROR := S0;                                            15162000
            TOS := CCL;                                                 15164000
            GO UNLK;                                                    15166000
            END;                                                        15168000
         IF P'REC AND REC >= 0D THEN                                    15170000
            BEGIN        << Random-access Delete >>                     15172000
            ACB'FPTR := REC;                                            15174000
            END;                                                        15176000
                                                                        15178000
         IOMOVE(%40,DUM,0);    << de-activate record >>                 15180000
         TOS := ACB'ERROR;                                              15182000
         TOS := ACBSTATUSCODE;                                          15184000
UNLK:                                                                   15186000
         UNLOC'ACB(ACBMQ,0);                                   <<01864>>15188000
         END; <<0>>                                                     15190000
                                                                        15192000
   <<1>> BEGIN     << remote file >>                                    15194000
         SETRFAPTR;      << Build message array on TOS.     >> <<01864>>15196000
         RFALEN := 7;    << Length of msg array (appendage).>> <<01864>>15198000
         TOS := "RFA ";                                        <<01864>>15200000
         TOS := %63;     << FDELETE DS code = intrinsic nr. >> <<01864>>15202000
         TOS := RFAFILE;  << File number on remote system.  >> <<01864>>15204000
         TOS := REC;      << Record number parameter.       >> <<01864>>15206000
         TOS := PARMMASK; << Option Variable mask.          >> <<01864>>15208000
         MWCNOBUF;      << Stack MANAGEWRITECONVERSATION... >> <<01864>>15210000
                        << ...boilerplate and call it.      >> <<01864>>15212000
         CHECKXFER;    << Check for DS err, not FDELETE err.>> <<01864>>15214000
         DELAPPENDAGE;  << Cut back stack except for status >> <<01864>>15216000
         TOS := TOS.CC; << This is remote FDELETE CC.       >> <<01864>>15218000
         ASSEMBLE(ZERO,XCH);     << Report no FSERR here.   >> <<01864>>15220000
         END; <<1>>                                                     15222000
                                                                        15224000
   <<2>> GOTO BADFTYPE;                                                 15226000
   <<3>> GOTO BADFTYPE;                                                 15228000
   <<4>> GOTO BADFTYPE;                                                 15230000
                                                                        15232000
   <<5>> BEGIN                                                          15234000
BADFTYPE:                                                               15236000
         TOS := SYSTEM;                                                 15238000
         TOS := CCL;                                                    15240000
         END;                                                           15242000
                                                                        15244000
   <<6>> BEGIN    << KSAM file >>                                       15246000
         TOS := ACCVIOL;                                                15248000
         TOS := CCL;                                                    15250000
         END;                                                           15252000
   <<7>> ;                                                     <<HM.00>>15254000
   <<8>> BEGIN  <<MSG FILE>>                                   <<HM.00>>15256000
         TOS:=ACCVIOL;                                         <<HM.00>>15258000
         TOS:=CCL;                                             <<HM.00>>15260000
         UNLOC'ACB(ACBMQ,0);                                   <<01864>>15262000
         END;                                                  <<HM.00>>15264000
      END;      << FTYPE CASE >>                                        15266000
                                                                        15268000
EXIT:                                                                   15270000
   CONDCODE := TOS;                                                     15272000
   RESETCRITICAL(CRIT);                                                 15274000
   ERROREXIT(4,S0,0);                                                   15276000
   END;      << procedure FDELETE >>                                    15278000
$PAGE " FREAD "                                                         15280000
$CONTROL SEGMENT = FILESYS1A  << FREAD >>                               15282000
                                                                        15284000
INTEGER PROCEDURE FREAD(FILENUM,TARGET,TCOUNT);                         15286000
VALUE FILENUM,TCOUNT;                                                   15288000
INTEGER FILENUM,TCOUNT;                                                 15290000
ARRAY TARGET;                                                           15292000
OPTION PRIVILEGED;                                                      15294000
   BEGIN                                                                15296000
                                                                        15298000
   ENTRY FREADX;    << secondary entry point for READX >>               15300000
   ENTRY FREADBACKWARD;                                                 15302000
                                                                        15304000
   EQUATE UBND = -8; <<Q rel upper bound for bounds check>>    <<03059>>15306000
   EQUATE INITIATE   = 0;                                      <<03038>>15308000
   LOGICAL READX,READBK;                                                15310000
   INTEGER CRIT;       << for SETCRITICAL >>                            15312000
                                                                        15314000
   << Remote file access (RFA) variables >>                             15316000
                                                                        15318000
   INTEGER POINTER RFAPTR;     << appendage pointer >>                  15320000
   INTEGER RFALEN;             << appendage length >>                   15322000
   LOGICAL LOCAL'FAILURE := 0;                                          15324000
                                                                        15326000
 << Following LOC'ACB params must be last and in order: >>              15328000
   INTEGER AFTE;                                                        15330000
   INTEGER PACBV;                                                       15332000
   INTEGER LACBV;                                                       15334000
   INTEGER IOQX;                                                        15336000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+11 >>                   15338000
   BUILD'ACB;                                                           15340000
   LOGICAL ACB'CTL      = ACB+11;                                       15342000
   INTEGER ACB'TLOG     = ACB+15;                                       15344000
                                                                        15346000
   INTEGER DSTX;      << user buffer data seg >>                        15348000
   << end of LOC'ACB params >>                                          15350000
                                                                        15352000
SUBROUTINE ATTIO(FUNC);                                        <<02054>>15354000
VALUE FUNC; INTEGER FUNC;                                               15356000
   << Shortcut to call ATTACHIO. >>                                     15358000
                                                                        15360000
   BEGIN                                                                15362000
   TOS := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,0,4,BFLAGS);                  15364000
   ASMB(DEL,DUP);                                                       15366000
   IF TOS.(8:8) <> 1 THEN                                               15368000
      BEGIN         << ATTACHIO reports error. >>                       15370000
      ASMB(ZERO,XCH);    << for result of IOSTAT >>                     15372000
      TOS := IOSTAT(*);                                                 15374000
      ASMB(TEST);                                              <<02693>>15376000
      IF <> AND S0 <> EOT AND S0 <> TAPERREC THEN GO NFG;      <<02712>>15378000
      DEL;                                                              15380000
      END                                                      <<02072>>15382000
   ELSE DEL;                                                   <<02073>>15384000
   END;            << subroutine ATTIO >>                      <<02072>>15386000
                                                                        15388000
   IF (READBK := FALSE) THEN                                            15390000
      BEGIN                                                             15392000
FREADBACKWARD:                                                          15394000
      READBK := TRUE;                                                   15396000
      END;                                                              15398000
   IF (READX := FALSE) THEN                                             15400000
      BEGIN                                                             15402000
FREADX:                                                                 15404000
      READBK := FALSE;                                                  15406000
      READX := TRUE;                                                    15408000
      END;                                                              15410000
                                                                        15412000
$  IF X0 = ON                                                           15414000
   IF MONCALLABLE THEN                                                  15416000
      BEGIN          << monitoring >>                                   15418000
      FTITLE("FREA","D   ",0D,0D);                                      15420000
      DEBUG                                                             15422000
      END;                                                              15424000
$  IF                                                                   15426000
                                                                        15428000
   ERRORON;                                                             15430000
   CRIT := SETCRITICAL;                                                 15432000
   IF READX THEN                                                        15434000
      BEGIN                                                             15436000
      IF NOT (PRIVMODE) THEN                                            15438000
         BEGIN                                                          15440000
         TOS := ILLCAP;                                                 15442000
         TOS := CCL;                                                    15444000
         GO EXIT;                                                       15446000
         END;                                                           15448000
      IF FILENUM <> 1 THEN                                              15450000
         BEGIN                                                          15452000
         TOS := INVFN;                                                  15454000
         TOS := CCL;                                                    15456000
         GO EXIT;                                                       15458000
         END;                                                           15460000
      END;                                                              15462000
   LOC'ACB(*,11,FILENUM,UMODE);                                         15464000
   IF < THEN                                                            15466000
      BEGIN     << invalid file nr. >>                                  15468000
      TOS := INVFN;                                                     15470000
      TOS := CCL;                                                       15472000
      GO EXIT                                                           15474000
      END;                                                              15476000
   IF > THEN                                                            15478000
      BEGIN     << $NULL >>                                             15480000
      TOS := 0;     << No error. >>                                     15482000
      TOS := CCG;   << Report EOF >>                                    15484000
      GO EXIT                                                           15486000
      END;                                                              15488000
                                                                        15490000
      <<* * * OK. Do FREAD  * * * >>                                    15492000
                                                                        15494000
   CASE * FTYPE OF                                                      15496000
      BEGIN                                                             15498000
                                                                        15500000
      BEGIN      << conventional file >>                                15502000
      IF IOQX <> 0 THEN                                                 15504000
         BEGIN    << No-wait I/O pending >>                             15506000
         TOS := IOPENDING;                                              15508000
         GO NFG                                                         15510000
         END;                                                           15512000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>15514000
         BEGIN                                                          15516000
         TOS := BNDVIOL;                                                15518000
         GO NFG                                                         15520000
         END;                                                           15522000
      IF (1 <= ACB'ACTYPE <= 3) THEN                                    15526000
         BEGIN      << Error: doesn't have READ access. >>              15528000
ACV:     TOS := ACCVIOL;                                                15530000
NFG:     ACB'ERROR := S0;                                               15532000
         TOS := CCL;                                                    15534000
         GO UNLK;                                                       15536000
         END;                                                           15538000
      IF READBK THEN                                                    15540000
         BEGIN     << FREADBACKWARD request >>                          15542000
         IF NOT ACB'INHIBITBUF THEN GO ACV;                             15544000
         IF ACB'DTYPE <> MTAPE THEN                            <<02037>>15546000
            BEGIN        << Not tape; bitch. >>                         15548000
            TOS := DEVVIOL;                                             15550000
            GO NFG                                                      15552000
            END;                                                        15554000
         ACB'FPTR := ACB'FPTR-DOUBLE(ACB'BLKFACT);                      15556000
         IF ACB'NEWEOF THEN                                    <<02054>>15558000
            BEGIN      << Write tapemark for high water. >>    <<02054>>15560000
            ATTIO(6);                                          <<02054>>15562000
            ATTIO(8);      << backspace over it >>             <<02054>>15564000
            ACB'NEWEOF := 0;                                   <<02054>>15566000
            END;                                               <<02054>>15568000
         END;                                                           15570000
      TOS := ACB'READCODE;    << EOF check type (12:2) & mode (14:2) >> 15572000
      ASMB(DUP,DUP);                                                    15574000
      IF TOS.(12:2) <> 0 THEN  << readtype >>                           15576000
         BEGIN                << job or session >>                      15578000
         ASMB(TBC 14);   << read mode >>                                15580000
         IF = THEN                                                      15582000
            BEGIN            << Non-CI. >>                              15584000
            IF READX THEN TOS := TOS LOR STDINXRD;  << 1 >>             15586000
            ASMB(DELB,DUP);                                             15588000
            ASMB(DUP,INCA);                                             15590000
            IF (TOS LAND ACB'EOFS) <> 0 THEN                            15592000
               BEGIN     << Unpassable EOF. >>                          15594000
               DDEL;                                                    15596000
               ACB'EOF := 1;                                            15598000
               ACB'STATUS := EOFCODE;                                   15600000
               ACB'ERROR := EOF;                                        15602000
               ACB'TLOG := 0;                                           15604000
               GO LEOF;                                                 15606000
               END;                                                     15608000
            TOS.(11:1) := 1;  << flag non-CI job/session >>             15610000
            ASMB(XCH);                                                  15612000
            END;                                                        15614000
         ASMB(TRBC 12);                                                 15616000
         IF <> THEN TOS := TOS LOR 1;   << session >>                   15618000
         ASMB(TBC 13);                                                  15620000
         IF <> THEN TOS := TOS LAND 4;   << job >>                      15622000
         END;                                                           15624000
      TOS := TOS&LSL(8);     << EOF spec. code >>                       15626000
      ACB'CTL := TOS LOR TOS;                                           15628000
                                                                        15630000
   << Skip over any unread user header tape labels >>                   15632000
      IF LABEL'DEVICE THEN                                     <<03582>>15634000
         BEGIN                                                 <<02545>>15636000
         TOS := CHECKUL(FILENUM,0,0);                          <<02545>>15638000
         IF < THEN GO NFG;    << error >>                      <<02545>>15640000
         DEL;                                                  <<02545>>15642000
         END;                                                  <<02545>>15644000
      IF ACB'ACCCL = SERIALIO AND ACB'NEWEOF THEN              <<04591>>15646000
         BEGIN  << Can't read directly after a serial write.>> <<04591>>15648000
         ACB'ERROR := INVOP;                                   <<04591>>15650000
         TOS := ACB'ERROR;                                     <<04591>>15652000
         TOS := CCL;                                           <<04591>>15654000
         GO UNLK;                                              <<04591>>15656000
         END;                                                  <<04591>>15658000
      TOS := IF ACB'NOWAIT THEN %30 ELSE %20;                           15660000
      IF READBK THEN TOS := TOS+6;                                      15662000
      IOMOVE(*,TARGET,TCOUNT);                                          15664000
      IF READBK THEN ACB'FPTR := ACB'FPTR-DOUBLE(ACB'BLKFACT);          15666000
                                                                        15668000
LEOF:                                                                   15670000
      FREAD := \ACB'TLOG\;                                              15672000
      IF ACB'GSTATUS = 1 THEN                                           15674000
         BEGIN             << Successful I/O. >>                        15676000
         TOS := IF ACB'ERROR = EOL                             <<02068>>15678000
            THEN CCL ELSE CCE;                                          15680000
                                                                        15682000
         <<* * * Measurement data on FREAD * * *>>                      15684000
                                                                        15686000
$        IF X3 = ON                                                     15688000
         IF MEAS'TAPE'ON THEN BEGIN                                     15690000
         IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                 15692000
            BEGIN                                                       15694000
            TOS := EFREAD;        << event code >>                      15696000
            TOS := FILENUM;       << file nr. >>                        15698000
            TOS.(0:1) := ACBHIT;  << buffer hit flag >>                 15700000
            MMSTAT(*,*,ACB'TLOG,0)  << measure event >>                 15702000
            END                                                         15704000
         END;       << of MEAS'TAPE'ON >>                               15706000
$        IF                                                             15708000
                                                                        15710000
         END     << successful I/O >>                                   15712000
      ELSE                                                              15714000
         BEGIN      << I/O error. >>                                    15716000
         IF ACB'ERROR = BOT THEN SET'LPDT'BOT(ACB'DADDR,1);    <<02545>>15718000
         TOS := ACBSTATUSCODE;  << condition code to return >>          15720000
         END;                                                           15722000
      TOS := ACB'ERROR;                                                 15724000
      ASMB(XCH);     << swap error nr. and cond. code >>                15726000
UNLK: UNLOC'ACB(11,0);    << release ACB >>                             15728000
      END;      << conventional file >>                                 15730000
                                                                        15732000
      BEGIN    << Remote file >>                               <<DS.00>>15734000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>15736000
         LOCAL'FAILURE := BNDVIOL;                             <<DS.04>>15738000
      SETRFAPTR;                                               <<DS.00>>15740000
      RFALEN := 5;                                             <<DS.00>>15742000
      TOS := "RFA ";                                           <<DS.00>>15744000
      IF RFAMREC THEN TOS := 24 ELSE TOS := 3;                 <<DS.03>>15746000
      LOAD'ERROR;                                              <<DS.04>>15748000
      TOS := RFAFILE;                                          <<DS.00>>15750000
      TOS := TCOUNT;                                           <<DS.00>>15752000
      GETMWCPARMS;                                             <<DS.00>>15754000
      TOS := 0D;                                               <<DS.00>>15756000
      TOS := @TARGET;                                          <<DS.00>>15758000
      TOS := TCOUNT;                                           <<DS.00>>15760000
      TOS := MWCPLABEL;                                        <<DS.00>>15762000
      ASMB(PCAL 0);                                            <<DS.00>>15764000
      FREAD := TOS;                                                     15766000
      CHECKXFER;                                               <<DS.00>>15768000
      DELAPPENDAGE;                                            <<DS.00>>15770000
      PREPRETURN;                                              <<DS.00>>15772000
      GO EXIT;                                                 <<DS.00>>15774000
      END;      << remote file >>                                       15776000
         << dummy for 2 >>;                                             15778000
         << dummy for 3 >>;                                             15780000
         << dummy for 4 >>;                                             15782000
         << dummy for 5 >>;                                             15784000
      BEGIN        << KSAM file >>                                      15786000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>15788000
         BEGIN                                                          15790000
         FKSAMBNDVIOL(FILENUM);                                         15792000
         TOS := BNDVIOL;                                                15794000
         TOS := CCL;                                                    15796000
         GO EXIT;                                                       15798000
         END;                                                           15800000
      TOS := KREAD(FILENUM,TARGET,TCOUNT);                     <<KS.00>>15802000
      FREAD := TOS;                                                     15804000
      PUSH(STATUS);                                            <<KS.00>>15806000
      TOS := TOS.CC;     << report condition code >>           <<KS.00>>15808000
      ASMB(ZERO,XCH);                                          <<KS.00>>15810000
      END;        << KSAM file >>                              <<KS.00>>15812000
                                                                        15814000
      <<DUMMY FOR 7>>;                                         <<HM.00>>15816000
      BEGIN  <<MESSAGE FILE>>                                  <<HM.00>>15818000
      IF IOQX <> 0 THEN                                        <<HM.00>>15820000
         BEGIN    << No-wait I/O pending >>                    <<HM.00>>15822000
         TOS := IOPENDING;                                     <<HM.00>>15824000
         GO NFG                                                <<HM.00>>15826000
         END;                                                  <<HM.00>>15828000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>15830000
         BEGIN                                                 <<HM.00>>15832000
         TOS := BNDVIOL;                                       <<HM.00>>15834000
         GO NFG                                                <<HM.00>>15836000
         END;                                                  <<HM.00>>15838000
      IF NOT ACBREAD THEN                                      <<HM.00>>15840000
         BEGIN                                                 <<HM.00>>15842000
         TOS:=ACCVIOL;                                         <<HM.00>>15844000
         GO NFG;                                               <<HM.00>>15846000
         END;                                                  <<HM.00>>15848000
      FCREAD(INITIATE,TARGET,TCOUNT);                          <<03038>>15850000
      FREAD:=ACB'TLOG;                                         <<HM.00>>15852000
      UNLOC'ACB(11,0);                                         <<HM.00>>15854000
      IF S0 <> 0 THEN FCAWAKEN(*) ELSE DEL;                    <<03038>>15856000
      TOS:=ACB'ERROR;                                          <<HM.00>>15858000
      ASMB(XCH);                                               <<HM.00>>15860000
      END;                                                     <<HM.00>>15862000
      END;       << FTYPE case >>                                       15864000
                                                                        15866000
EXIT:                                                                   15868000
   CONDCODE := TOS;          << report condition code >>                15870000
   RESETCRITICAL(CRIT);                                                 15872000
   ERROREXIT(3,S0,0)                                                    15874000
   END;       << procedure FREAD >>                                     15876000
$PAGE " FWRITE "                                                        15878000
$CONTROL SEGMENT = FILESYS1A  << FWRITE >>                              15880000
                                                                        15882000
PROCEDURE FWRITE(FILENUM,TARGET,TCOUNT,CONTROL);                        15884000
VALUE FILENUM,TCOUNT,CONTROL;                                           15886000
INTEGER FILENUM,TCOUNT;                                                 15888000
LOGICAL CONTROL;                                                        15890000
ARRAY TARGET;                                                           15892000
OPTION PRIVILEGED;                                                      15894000
   BEGIN                                                                15896000
   EQUATE UBND = -8; <<Q rel upper bound for bounds check>>    <<03059>>15898000
   EQUATE INITIATE   = 0;                                      <<03038>>15900000
   EQUATE                  << CCTL to open SDISC            >> <<03731>>15902000
      SETCONTIG = %1001;   <<   contiguous block.           >> <<03731>>15904000
                                                                        15906000
   << Remote file access (RFA) variables >>                             15908000
                                                                        15910000
   INTEGER POINTER RFAPTR;    << appendage pointer >>          <<DS.00>>15912000
   INTEGER RFALEN;            << appendage length >>           <<DS.00>>15914000
   LOGICAL LOCAL'FAILURE := 0;                                 <<DS.04>>15916000
                                                                        15918000
   INTEGER CRIT;         << for SETCRITICAL >>                          15920000
<< Following LOC'ACB params must be last and in order: >>               15922000
   INTEGER ACBMQ;                                              <<04591>>15924000
   INTEGER AFTE;                                                        15926000
   INTEGER PACBV;                                                       15928000
   INTEGER LACBV;                                                       15930000
   INTEGER IOQX;                                                        15932000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+9 >>                    15934000
   BUILD'ACB;                                                           15936000
   LOGICAL ACB'CTL      = ACB+11;                                       15938000
                                                                        15940000
   INTEGER DSTX;       << user's buffer DST >>                          15942000
   << End of LOC'ACB params >>                                          15944000
                                                               <<HM.00>>15946000
   SUBROUTINE FORMCARRCONTROL;                                 <<HM.00>>15948000
<< This subroutine processes carriage control characters. >>            15950000
                                                                        15952000
      BEGIN                                                    <<HM.00>>15954000
      IF ACB'CONTROL THEN                                      <<HM.00>>15956000
         BEGIN       << File has carriage control. >>          <<HM.00>>15958000
         IF CONTROL = 1 THEN                                   <<HM.00>>15960000
            BEGIN      << Car control already in line. >>      <<HM.00>>15962000
            IF TCOUNT = 0 THEN                                 <<HM.00>>15964000
               BEGIN   << Woops! Must have car control, at least HM.00>>15966000
               TOS := BADCONTROL;                              <<HM.00>>15968000
               GO NFG                                          <<HM.00>>15970000
               END;                                            <<HM.00>>15972000
            X := TARGET(0).(0:8) << get col 1. line/page control HM.00>>15974000
            END                                                <<HM.00>>15976000
         ELSE                                                  <<HM.00>>15978000
            BEGIN      << separate control >>                  <<HM.00>>15980000
            X := CONTROL;                                      <<HM.00>>15982000
            IF (%400 <= X <= %403) THEN                        <<HM.00>>15984000
               CONTROL := X := X-%300;    << re-map control >> <<HM.00>>15986000
            END;     << separate control >>                    <<HM.00>>15988000
         IF (%100 <= X <= %103) THEN                           <<HM.00>>15990000
            BEGIN     << Set ACB line & page controls. >>      <<HM.00>>15992000
            IF (%100 <= X <= %101) THEN                        <<HM.00>>15994000
               ACB'LINECTL := X         << new line control >> <<01720>>15996000
            ELSE IF (%102 <= X <= %103) THEN                   <<HM.00>>15998000
               ACB'PAGECTL := X;         << new page control >><<01720>>16000000
            IF TCOUNT = 0 THEN                                 <<HM.00>>16002000
               BEGIN          << Control only - no text. >>    <<HM.00>>16004000
               TOS: = 0;      << Take quick exit. >>           <<HM.00>>16006000
               TOS := CCE;                                     <<HM.00>>16008000
               GO UNLK;                                        <<HM.00>>16010000
               END;    << control only  >>                     <<HM.00>>16012000
            END;     << set ACB line & page controls >>        <<HM.00>>16014000
         ACB'CTL := CONTROL                                    <<HM.00>>16016000
         END       << file has carriage control >>             <<HM.00>>16018000
      ELSE         << Carriage control not allowed; ignore >>  <<HM.00>>16020000
         ACB'CTL := 0;                                         <<HM.00>>16022000
      END  <<FORMCARRCONTROL>>;                                <<HM.00>>16024000
                                                                        16026000
$  IF X0 = ON                                                           16028000
   IF MONCALLABLE THEN                                                  16030000
      BEGIN          << monitoring >>                                   16032000
      FTITLE("FWRI","TE  ",0D,0D);                                      16034000
      DEBUG                                                             16036000
      END;                                                              16038000
$  IF                                                                   16040000
                                                                        16042000
   ERRORON;                                                             16044000
   CRIT := SETCRITICAL;                                                 16046000
   GET'ACB'Q'LOC;                                              <<04591>>16048000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<04591>>16050000
   IF < THEN                                                            16052000
      BEGIN          << invalid file nr. >>                             16054000
      TOS := INVFN;                                                     16056000
      TOS := CCL;                                                       16058000
      GO EXIT                                                           16060000
      END;                                                              16062000
   IF > THEN                                                            16064000
      BEGIN           << $NULL is a bit bucket. >>                      16066000
      TOS := 0;       << No error. >>                                   16068000
      TOS := CCE;                                                       16070000
      GO EXIT                                                           16072000
      END;                                                              16074000
                                                                        16076000
      <<* * * OK. Do WRITE  * * *>>                                     16078000
                                                                        16080000
   CASE * FTYPE OF                                                      16082000
      BEGIN                                                             16084000
                                                                        16086000
      BEGIN         << conventional file >>                             16088000
      IF IOQX <> 0 THEN                                                 16090000
         BEGIN           << No-wait I/O pending >>                      16092000
         TOS := IOPENDING;                                              16094000
         GO NFG                                                         16096000
         END;                                                           16098000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>16100000
         BEGIN                                                          16102000
         TOS := BNDVIOL;                                                16104000
         GO NFG                                                         16106000
         END;                                                           16108000
      TOS := ACB'ACTYPE;     << access type >>                          16110000
      IF = THEN                                                         16112000
         BEGIN       << Read only. >>                                   16114000
         TOS := ACCVIOL;                                                16116000
NFG:     ACB'ERROR := S0;                                               16118000
         TOS := CCL;                                                    16120000
         GO UNLK;                                                       16122000
         END;                                                           16124000
      IF TOS=3 AND ACBACCCL=DIRACC AND NOT ACBCIRFILE          <<HM.00>>16126000
          AND ACB'DTYPE <> FDISC THEN                          <<01115>>16128000
         ACB'FPTR := GETFCB'INFO(ACB'FCB,XEOF);  << APPEND mode >>      16130000
      FORMCARRCONTROL;  <<GET THE USER'S CARR CONTROL>>        <<HM.00>>16132000
      IF LABEL'DEVICE THEN                                     <<03582>>16134000
         BEGIN                                                 <<02545>>16136000
         TOS := CHECKUL(FILENUM,1,ACB'NEWEOF);                 <<02545>>16138000
         IF < THEN GO NFG;   << error >>                       <<02545>>16140000
         DEL;                                                  <<02545>>16142000
         END;                                                  <<02545>>16144000
      IF ACB'DTYPE = SDISC AND CONTROL >= SETCONTIG AND        <<03753>>16146000
         NOT (PRIVMODE) THEN                                   <<03753>>16148000
            BEGIN            << Special SDISC control codes >> <<03731>>16150000
            TOS := ILLCAP;   << not allowed in user mode.   >> <<03731>>16152000
            GO NFG;                                            <<03731>>16154000
            END;                                               <<03731>>16156000
                                                               <<04591>>16158000
      <<****************************************************>> <<04591>>16160000
      << If the last operation to a serialio device was a   >> <<04591>>16162000
      << read, then obtain the number of pre-reads from     >> <<04591>>16164000
      << FQUIESC'IO so that we may back space over them be- >> <<04591>>16166000
      << fore performing the write.                         >> <<04591>>16168000
      <<****************************************************>> <<04591>>16170000
                                                               <<04591>>16172000
      IF ACB'ACCCL = SERIALIO AND NOT ACB'INHIBITBUF AND       <<04591>>16174000
         NOT ACB'NEWEOF THEN                                   <<04591>>16176000
         BEGIN                                                 <<04591>>16178000
         TOS := FQUIESCE'IO(FALSE); << TOS MUST MUST be used>> <<04591>>16180000
         ACB'TAPEDISP := TOS; << so the ACB is at Q-62!!!!! >> <<04591>>16182000
         END;                                                  <<04591>>16184000
      ACB'NEWEOF := 1;                                                  16186000
                                                               <<04159>>16188000
      TOS := IF ACB'DTYPE=SDISC THEN CONTROL LOR 1 ELSE                 16192000
           IF ACB'NOWAIT THEN %31 ELSE %21;                    <<04590>>16194000
      IOMOVE(*,TARGET,TCOUNT);                                          16196000
      IF ACB'ERROR = EOT THEN                                           16198000
         BEGIN           << End of tape >>                              16200000
         IF ACB'DTYPE = PTPNCH THEN                                     16202000
            BEGIN      << Paper tape punch. Do trailer >>               16204000
            TOS := ATTACHIO(ACB'DADDR,0,0,0,5,0,0,0,BFLAGS);            16206000
            DEL;          << discard TLOG >>                            16208000
            ACB'STATUS := TOS;                                          16210000
            IF ACB'GSTATUS <> 1 THEN                                    16212000
               BEGIN             << Error. >>                           16214000
               TOS := CCL;                                              16216000
               TOS := IOSTAT(ACB'STATUS)  << convert error nr. >>       16218000
               END                                                      16220000
            ELSE                                                        16222000
               BEGIN              << OK. >>                             16224000
               TOS := CCE;                                              16226000
               TOS := 0           << Clear error >>                     16228000
               END;                                                     16230000
            ACB'ERROR := TOS                                            16232000
            END      << paper tape punch >>                             16234000
         ELSE       << Magnetic tape >>                                 16236000
         TOS := CCL;                                           <<02545>>16238000
         END         << end of tape >>                                  16242000
      ELSE                                                              16244000
         TOS := ACBSTATUSCODE;  << report CC per status >>              16246000
                                                                        16248000
      <<* * * Measurement data on FWRITE * * *>>                        16250000
                                                                        16252000
$     IF X3 = ON                                                        16254000
      IF MEAS'TAPE'ON THEN BEGIN                                        16256000
      IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                    16258000
         BEGIN                 << Record the measurement >>             16260000
         TOS := EFWRITE;         << event code >>                       16262000
         TOS := FILENUM;         << file nr. >>                         16264000
         TOS.(0:1) := ACBHIT;    << buffer hit flag >>                  16266000
         MMSTAT(*,*,TCOUNT,0)    << measure event >>                    16268000
         END;                                                           16270000
      END;     << of MEAS'TAPE'ON>>                                     16272000
$     IF                                                                16274000
                                                                        16276000
      TOS := ACB'ERROR;                                                 16278000
      ASMB(XCH);       << swap error nr. and cond. code >>              16280000
UNLK: UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<04591>>16282000
      END;        << conventional file >>                               16284000
                                                                        16286000
      BEGIN      << Remote file >>                                      16288000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>16290000
         BEGIN                                                 <<DS.04>>16292000
         LOCAL'FAILURE := BNDVIOL;                             <<DS.04>>16294000
         TCOUNT := 0;                                          <<DS.06>>16296000
         END;                                                  <<DS.04>>16298000
      SETRFAPTR;                                               <<DS.00>>16300000
      RFALEN := 6;                                             <<DS.00>>16302000
      TOS := "RFA ";                                           <<DS.00>>16304000
      IF RFAMREC THEN TOS := 26 ELSE TOS := 6;                 <<DS.03>>16306000
      LOAD'ERROR;                                              <<DS.04>>16308000
      TOS := RFAFILE;                                          <<DS.00>>16310000
      TOS := TCOUNT;                                           <<DS.00>>16312000
      TOS := CONTROL;                                          <<DS.00>>16314000
      GETMWCPARMS;                                             <<DS.00>>16316000
      IF RFAMREC THEN TOS := 0D ELSE                           <<DS.03>>16318000
         BEGIN                                                 <<DS.03>>16320000
         TOS := @TARGET;                                       <<DS.03>>16322000
         TOS := TCOUNT;                                        <<DS.03>>16324000
         END;                                                  <<DS.03>>16326000
      TOS := 0D;                                               <<DS.00>>16328000
      TOS := MWCPLABEL;                                        <<DS.00>>16330000
      ASMB(PCAL 0);                                            <<DS.00>>16332000
      DEL;                                                     <<DS.00>>16334000
      CHECKXFER;                                               <<DS.00>>16336000
      IF RFAMREC AND LOCAL'FAILURE = 0 THEN                    <<DS.04>>16338000
         BEGIN                                                 <<DS.03>>16340000
         RFALEN := 0;                                          <<DS.03>>16342000
         GETMWCPARMS;                                          <<DS.03>>16344000
         TOS := @TARGET;                                       <<DS.03>>16346000
         TOS := TCOUNT;                                        <<DS.03>>16348000
         TOS := 0D;                                            <<DS.03>>16350000
         TOS := MWCPLABEL;                                     <<DS.03>>16352000
         ASMB(PCAL 0);     << Send data across >>              <<DS.03>>16354000
         DEL;                                                  <<DS.03>>16356000
         CHECKXFER;                                            <<DS.03>>16358000
         RFALEN := 6;                                          <<DS.03>>16360000
         END;                                                  <<DS.03>>16362000
      DELAPPENDAGE;                                            <<DS.00>>16364000
      PREPRETURN;                                              <<DS.00>>16366000
      GO EXIT;                                                          16368000
      END;     << remote file >>                                        16370000
                                                                        16372000
            << dummy for 2 >>;                                          16374000
            << dummy for 3 >>;                                          16376000
            << dummy for 4 >>;                                          16378000
            << dummy for 5 >>;                                          16380000
      BEGIN       << KSAM file >>                                       16382000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>16384000
         BEGIN                                                          16386000
         FKSAMBNDVIOL(FILENUM);                                <<KS.00>>16388000
         TOS := BNDVIOL;                                                16390000
         TOS := CCL;                                                    16392000
         GO EXIT;                                                       16394000
         END;                                                           16396000
      KWRITE(FILENUM,TARGET,TCOUNT);                           <<KS.00>>16398000
      PUSH(STATUS);                                            <<KS.00>>16400000
      TOS := TOS.CC;                                           <<KS.00>>16402000
      ASMB(ZERO,XCH);                                          <<KS.00>>16404000
      END;      << KSAM file >>                                <<KS.00>>16406000
      <<DUMMY FOR 7>>;                                         <<HM.00>>16408000
      BEGIN  <<MESSAGE FILE>>                                  <<HM.00>>16410000
      IF IOQX <> 0 THEN                                        <<HM.00>>16412000
         BEGIN           << No-wait I/O pending >>             <<HM.00>>16414000
         TOS := IOPENDING;                                     <<HM.00>>16416000
         GO NFG                                                <<HM.00>>16418000
         END;                                                  <<HM.00>>16420000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>16422000
         BEGIN                                                 <<HM.00>>16424000
         TOS := BNDVIOL;                                       <<HM.00>>16426000
         GO NFG                                                <<HM.00>>16428000
         END;                                                  <<HM.00>>16430000
      IF NOT (1 <= ACBACTYPE <= 3) THEN                        <<HM.00>>16432000
         BEGIN                                                 <<HM.00>>16434000
         TOS:=ACCVIOL;                                         <<HM.00>>16436000
         GO NFG;                                               <<HM.00>>16438000
         END;                                                  <<HM.00>>16440000
      FORMCARRCONTROL;                                         <<HM.00>>16442000
      FCWRITE(INITIATE,TARGET,TCOUNT);                         <<03038>>16444000
      UNLOC'ACB(ACBMQ,0);                                      <<04591>>16446000
      IF S0 <> 0 THEN FCAWAKEN(*) ELSE DEL;                    <<03038>>16448000
      TOS:=ACB'ERROR;                                          <<HM.00>>16450000
      ASMB(XCH);                                               <<HM.00>>16452000
      END;                                                     <<HM.00>>16454000
      END;         << FTYPE case >>                                     16456000
                                                                        16458000
EXIT:                                                                   16460000
   CONDCODE := TOS;  << store condition code >>                         16462000
   RESETCRITICAL(CRIT);                                                 16464000
   ERROREXIT(4,S0,0)                                                    16466000
   END;        << procedure FWRITE >>                                   16468000
$PAGE " FREADDIR - FWRITEDIR "                                          16470000
$CONTROL SEGMENT = FILESYS1A  << FREADDIR/FWRITEDIR >>                  16472000
                                                                        16474000
PROCEDURE FREADDIR(FILENUM,TARGET,TCOUNT,REC);  <<and FWRITEDIR>>       16476000
VALUE FILENUM,TCOUNT,REC;                                               16478000
INTEGER FILENUM,TCOUNT;                                                 16480000
DOUBLE REC;                                                             16482000
ARRAY TARGET;                                                           16484000
OPTION PRIVILEGED;                                                      16486000
   BEGIN                                                                16488000
   ENTRY FWRITEDIR;                                                     16490000
   INTEGER POINTER AFT;     << for KSAM >>                     <<KS.00>>16492000
   EQUATE UBND = -9; <<Q rel upper bound for bounds check>>    <<03059>>16494000
   LOGICAL CODE;       << 0=READ, 1=WRITE >>                            16496000
   DEFINE READ = NOT CODE#,                                             16498000
          WRITE = CODE#;                                                16500000
   INTEGER CRIT;       << for SETCRITICAL >>                            16502000
   DOUBLE SAVE'FPTR;                                           <<01759>>16504000
                                                                        16506000
   << Remote file access (RFA) variables: >>                            16508000
                                                                        16510000
   INTEGER POINTER RFAPTR;    << appendage pointer >>                   16512000
   INTEGER RFALEN;            << appendage length >>                    16514000
   LOGICAL LOCAL'FAILURE := 0;                                          16516000
   LOGICAL IMAGE'ACCESS := 0;                                  <<04874>>16518000
   INTEGER ACBMQ;      << Q relative address of ACB >>         <<04874>>16520000
                                                                        16522000
   << Following LOC'ACB params must be last and in order: >>            16524000
   INTEGER AFTE;       << AFT entry word 0 >>                           16526000
   INTEGER PACBV;                                                       16528000
   INTEGER LACBV;                                                       16530000
   INTEGER IOQX;                                                        16532000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<04874>>16534000
   BUILD'ACB;                                                           16536000
   DOUBLE ACB'BLK       = ACB+18;                                       16538000
                                                                        16540000
   LOGICAL DSTX;      << DST nr. of caller's buffer (where DB is) >>    16542000
   << end of LOC'ACB params >>                                          16544000
                                                                        16546000
   TOS := 0;          << flag for Read >>                               16548000
   RFALEN := S0;                                                        16550000
   GO CONT;                                                             16552000
FWRITEDIR:                                                              16554000
   TOS := 1;          << flag for Write >>                              16556000
   IMAGE'ACCESS := FALSE;                                      <<04874>>16558000
   IF FILENUM < 0 AND PRIVMODE THEN                                     16560000
      BEGIN   <<  Image is allowed access even if open read >> <<04874>>16562000
      FILENUM := -FILENUM;                                     <<04874>>16564000
      IMAGE'ACCESS := TRUE;                                    <<04874>>16566000
      END;                                                     <<04874>>16568000
CONT:                                                                   16570000
   CODE := TOS;                                                         16572000
                                                                        16574000
$  IF X0 = ON                                                           16576000
   IF MONCALLABLE THEN                                                  16578000
      BEGIN          << monitoring >>                                   16580000
      FTITLE("FREA","D/WR","ITED","IR  ");                              16582000
      DEBUG                                                             16584000
      END;                                                              16586000
$  IF                                                                   16588000
                                                                        16590000
   ERRORON;                                                             16592000
   CRIT := SETCRITICAL;                                                 16594000
   GET'ACB'Q'LOC;                                              <<04874>>16596000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<04874>>16598000
   IF < THEN                                                            16600000
      BEGIN    << invalid file nr. >>                                   16602000
      TOS := INVFN;                                                     16604000
      TOS := CCL;                                                       16606000
      GO EXIT                                                           16608000
      END;                                                              16610000
   IF > THEN                                                            16612000
      BEGIN   << $NULL >>                                               16614000
      TOS := 0;        << No error. >>                                  16616000
      TOS := IF WRITE THEN CCE ELSE CCG;                                16618000
      GO EXIT                                                           16620000
      END;                                                              16622000
                                                                        16624000
      <<* * * OK * * *>>                                                16626000
                                                                        16628000
   CASE * FTYPE OF                                                      16630000
      BEGIN                                                             16632000
                                                                        16634000
      BEGIN     << conventional file >>                                 16636000
      IF IOQX <> 0 THEN                                                 16638000
         BEGIN     << No-wait I/O pending >>                            16640000
         TOS := IOPENDING;                                              16642000
         GO NFG                                                         16644000
         END;                                                           16646000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>16648000
         BEGIN           << Out of bounds. >>                           16650000
         TOS := BNDVIOL;                                                16652000
         GO NFG                                                         16654000
         END;                                                           16656000
      IF ACB'ACCCL <> DIRACC OR ACB'SPOOLED THEN                        16658000
         BEGIN          << Not disk file. Barf! >>                      16660000
         TOS := DEVVIOL;                                                16662000
         GO NFG                                                         16664000
         END;                                                           16666000
                                                               <<04874>>16668000
       <<*******************************************>>         <<04874>>16670000
       <<  We will allow IMAGE access even if the   >>         <<04874>>16672000
       <<  file is open read only.                  >>         <<04874>>16674000
       <<*******************************************>>         <<04874>>16676000
                                                               <<04874>>16678000
      IF IMAGE'ACCESS THEN                                     <<04874>>16680000
       << No checking >>                                       <<04874>>16682000
      ELSE IF WRITE THEN                                       <<04874>>16686000
         BEGIN          << FWRITEDIR >>                                 16688000
         IF (ACB'ACTYPE=0) OR (ACB'ACTYPE=3) OR ACB'CIRFILE    <<01555>>16690000
            THEN  <<INPUT, APPEND, OR CIRCULAR FILE?>>         <<01555>>16692000
         IF = OR TOS = 3 OR ACB'CIRFILE THEN <<INPUT OR APPEND?  HM.00>>16694000
            BEGIN     << INPUT or APPEND only. Sorry, Charlie. >>       16696000
E1:         TOS := ACCVIOL;                                             16698000
NFG:        ACB'ERROR := S0;                                            16700000
            TOS := CCL;                                                 16702000
            GO UNLK;                                                    16704000
            END                                                         16706000
         END                                                            16708000
      ELSE      << FREADDIR >>                                          16710000
         IF (1 <= ACB'ACTYPE <= 3) THEN GO E1; << haven't READ access >>16712000
      IF ACB'NORMVAR THEN GO E1;   << no random access for these >>     16714000
      SAVE'FPTR := ACB'FPTR;                                   <<01759>>16716000
      TOS := CODE;                                                      16720000
      IF ACB'NOWAIT THEN TOS := TOS+%30;                                16722000
      TOS := @TARGET;                                                   16724000
      TOS := TCOUNT;                                                    16726000
      IF ACB'SPECVAR THEN ACB'BLK := REC ELSE ACB'FPTR := REC;          16728000
      IF NOT ACB'INHIBITBUF THEN                                        16730000
         BEGIN        << Buffered access >>                             16732000
         IOMOVE(*,*,*);                                                 16734000
         END                                                   <<00630>>16736000
      ELSE                                                              16738000
         BEGIN       << NOBUF access >>                                 16740000
         TOS := REC;     << Block number! >>                            16742000
         X := ACB'BLKFACT;                                              16744000
         MPYD;         << convert to record number >>                   16746000
         ACB'FPTR := TOS;                                               16748000
         IOMOVE(*,*,*);                                                 16750000
         END;                                                           16752000
      TOS := ACB'ERROR;       << error nr. >>                           16754000
      TOS := ACBSTATUSCODE;  << Condition code to report >>             16756000
      IF S0.(14:2) <> CCE THEN ACB'FPTR := SAVE'FPTR;          <<01759>>16758000
                                                                        16760000
      <<* * * Measurement data on FREADDIR/FWRITEDIR * * *>>            16762000
                                                                        16764000
$  IF X3 = ON                                                           16766000
      IF MEAS'TAPE'ON THEN BEGIN                                        16768000
      IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                    16770000
         BEGIN       << Measure >>                                      16772000
         TOS := IF READ THEN EFREADDIR ELSE EFWRITEDIR;                 16774000
         TOS := FILENUM;                                                16776000
         TOS.(0:1) := ACBHIT;  << buffer hit flag >>                    16778000
         TOS := IF READ THEN ACBTLOG ELSE TCOUNT;                       16780000
         MMSTAT(*,*,*,0);                                               16782000
         TOS := IF READ THEN EFREADDIR' ELSE EFWRITEDIR';               16784000
         TOS := REC;     << record or block number >>                   16786000
         IF ACB'INHIBITBUF THEN                                         16788000
            BEGIN    << NOBUF; convert block to record. >>              16790000
            X := ACB'BLKFACT;                                           16792000
            MPYD                                                        16794000
            END;                                                        16796000
         MMSTAT(*,*,*,0)                                                16798000
         END                                                            16800000
      END;     << of MEAS'TAPE'ON>>                                     16802000
$  IF                                                                   16804000
                                                                        16806000
UNLK: UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<04874>>16808000
      END;       << conventional file >>                                16810000
                                                                        16812000
      BEGIN       << Remote file >>                                     16814000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>16816000
         BEGIN                                                 <<DS.04>>16818000
         LOCAL'FAILURE := BNDVIOL;                             <<DS.04>>16820000
         TCOUNT := 0;                                          <<DS.06>>16822000
         END;                                                  <<DS.04>>16824000
      SETRFAPTR;                                               <<DS.00>>16826000
      RFALEN := 7;                                             <<DS.00>>16828000
      TOS := "RFA ";                                           <<DS.00>>16830000
      IF WRITE THEN               << FWRITEDIR >>              <<DS.03>>16832000
         IF RFAMREC THEN TOS := 27 ELSE TOS := 7               <<DS.03>>16834000
      ELSE                                                     <<DS.03>>16836000
         IF RFAMREC THEN TOS := 25 ELSE TOS := 4;              <<DS.03>>16838000
      LOAD'ERROR;                                              <<DS.04>>16840000
      TOS := RFAFILE;                                          <<DS.00>>16842000
      TOS := TCOUNT;                                           <<DS.00>>16844000
      TOS := REC;                                              <<DS.00>>16846000
      TOS := 0;     << stack MWC parameters >>                 <<DS.00>>16848000
      TOS := RFALINE;                                          <<DS.00>>16850000
      TOS := RFAMSG;                                           <<DS.00>>16852000
      TOS := RFASTREAM;                                        <<DS.00>>16854000
      TOS := RFASUBSTR;                                        <<DS.00>>16856000
      TOS := @RFAPTR;                                          <<DS.00>>16858000
      TOS := RFALEN;                                           <<DS.00>>16860000
      IF WRITE THEN                                            <<DS.03>>16862000
         BEGIN         << FWRITEDIR >>                         <<DS.03>>16864000
         IF RFAMREC THEN TOS := 0D ELSE                        <<DS.03>>16866000
            BEGIN                                              <<DS.03>>16868000
            TOS := @TARGET;                                    <<DS.03>>16870000
            TOS := TCOUNT;                                     <<DS.03>>16872000
            END;                                               <<DS.03>>16874000
         TOS := 0D;                                            <<DS.03>>16876000
         END                                                            16878000
      ELSE                                                              16880000
         BEGIN     << FREADDIR >>                              <<DS.03>>16882000
         TOS := 0D;                                            <<DS.03>>16884000
         TOS := @TARGET;                                       <<DS.03>>16886000
         TOS := TCOUNT;                                        <<DS.03>>16888000
         END;                                                  <<DS.03>>16890000
      TOS := MWCPLABEL;                                        <<DS.00>>16892000
      ASMB(PCAL 0);                                            <<DS.00>>16894000
      DEL;                                                     <<DS.00>>16896000
      CHECKXFER;                                               <<DS.00>>16898000
      IF WRITE AND RFAMREC AND LOCAL'FAILURE=0 THEN            <<DS.04>>16900000
         BEGIN       << Send data across >>                    <<DS.03>>16902000
         RFALEN := 0;                                          <<DS.03>>16904000
         GETMWCPARMS;                                          <<DS.03>>16906000
         TOS := @TARGET;                                       <<DS.03>>16908000
         TOS := TCOUNT;                                        <<DS.03>>16910000
         TOS := 0D;                                            <<DS.03>>16912000
         TOS := MWCPLABEL;                                     <<DS.03>>16914000
         ASMB(PCAL 0);                                         <<DS.03>>16916000
         DEL;                                                  <<DS.03>>16918000
         CHECKXFER;                                            <<DS.03>>16920000
         RFALEN := 7;                                          <<DS.03>>16922000
         END;                                                  <<DS.03>>16924000
      DELAPPENDAGE;                                            <<DS.00>>16926000
      PREPRETURN;                                              <<DS.00>>16928000
      GO EXIT;                                                 <<DS.00>>16930000
      HELP;   << dummy call >>                                          16932000
      END;       << remote file >>                                      16934000
        << dummy 2 >>;                                                  16936000
        << dummy 3 >>;                                                  16938000
        << dummy 4 >>;                                                  16940000
        << dummy 5 >>;                                                  16942000
      BEGIN      << KSAM file >>                                        16944000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>16946000
         BEGIN           << Out of bounds. >>                           16948000
         FKSAMBNDVIOL(FILENUM);                                <<KS.00>>16950000
         TOS := BNDVIOL;                                                16952000
         GO KNFG                                                        16954000
         END;                                                           16956000
      IF READ THEN                                             <<KS.00>>16958000
         BEGIN     << FREADDIR >>                              <<KS.00>>16960000
         KREADDIR(FILENUM,TARGET,TCOUNT,REC);                  <<KS.00>>16962000
         PUSH(STATUS);                                         <<KS.00>>16964000
         TOS := TOS.CC;                                        <<KS.00>>16966000
         ASMB(ZERO,XCH);                                       <<KS.00>>16968000
         END    << FREADDIR >>                                 <<KS.00>>16970000
      ELSE                                                     <<KS.00>>16972000
         BEGIN    << FWRITEDIR >>                              <<KS.00>>16974000
         TOS := UNIMPL;      <<"unimplemented">>               <<KS.00>>16976000
KNFG:    DSTX := EXCHANGEDB(0);    << to stack >>              <<KS.00>>16978000
         SETAFT;                                               <<KS.00>>16980000
         AFTFLAG := 3;      << KSAM error >>                   <<KS.00>>16982000
         AFTERRNUM := S0;                                               16984000
         TOS := CCL;                                           <<KS.00>>16986000
         EXCHANGEDB(DSTX);                                     <<KS.00>>16988000
         END;      << FWRITEDIR >>                             <<KS.00>>16990000
      END;      << KSAM file >>                                         16992000
                                                                        16994000
         <<DUMMY 7>>;                                          <<HM.00>>16996000
         BEGIN                                                 <<HM.00>>16998000
         TOS:=ACCVIOL;                                         <<HM.00>>17000000
         GO NFG;                                               <<HM.00>>17002000
         END;                                                  <<HM.00>>17004000
      END;    << FTYPE CASE >>                                          17006000
                                                                        17008000
EXIT:                                                                   17010000
   CONDCODE := TOS;        << report condition code >>                  17012000
   RESETCRITICAL(CRIT);                                                 17014000
   ERROREXIT(5,S0,0)                                                    17016000
   END;         << procedure FREADDIR/FWRITEDIR >>                      17018000
$PAGE " FUPDATE "                                                       17020000
$CONTROL SEGMENT = FILESYS2   << FUPDATE >>                             17022000
PROCEDURE FUPDATE(FILENUM,TARGET,TCOUNT);                               17024000
VALUE FILENUM,TCOUNT;                                                   17026000
INTEGER FILENUM,TCOUNT;                                                 17028000
ARRAY TARGET;                                                           17030000
OPTION PRIVILEGED;                                                      17032000
   BEGIN                                                                17034000
   EQUATE UBND = -7; <<Q rel upper bound for bounds check>>    <<03059>>17036000
   INTEGER CRIT;        << for SETCRITICAL >>                           17038000
                                                                        17040000
   << Remote file access (RFA) variables: >>                            17042000
                                                                        17044000
   INTEGER POINTER RFAPTR;    << appendage pointer >>                   17046000
   INTEGER RFALEN;            << appendage length >>                    17048000
   LOGICAL LOCAL'FAILURE := 0;                                 <<DS.04>>17050000
   INTEGER WC;                                                          17052000
                                                                        17054000
   << Following LOC'ACB params must be last and in order: >>            17056000
   INTEGER AFTE;      << AFT entry word 0 >>                            17058000
   INTEGER PACBV;                                                       17060000
   INTEGER LACBV;                                                       17062000
   INTEGER IOQX;                                                        17064000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+10 >>                   17066000
   BUILD'ACB;                                                           17068000
   LOGICAL DSTX;     << DST nr. of caller's buffer >>                   17070000
   << end of LOC'ACB params >>                                          17072000
                                                                        17074000
$  IF X0 = ON                                                           17076000
   IF MONCALLABLE THEN DEBUG;  << monitoring >>                         17078000
$  IF                                                                   17080000
                                                                        17082000
   ERRORON;                                                             17084000
   WC := IF TCOUNT < 0 THEN (-TCOUNT+1)&LSR(1) ELSE TCOUNT;             17086000
   CRIT := SETCRITICAL;                                                 17088000
   LOC'ACB(*,10,FILENUM,0);                                             17090000
   IF < THEN                                                            17092000
      BEGIN         << invalid file nr. >>                              17094000
      TOS := INVFN;                                                     17096000
      TOS := CCL;                                                       17098000
      GO EXIT                                                           17100000
      END;                                                              17102000
   IF > THEN                                                            17104000
      BEGIN        << $NULL >>                                          17106000
      TOS := 0;        << No error. >>                                  17108000
      TOS := CCE;                                                       17110000
      GO EXIT                                                           17112000
      END;                                                              17114000
                                                                        17116000
      <<* * * OK.  Do FUPDATE * * *>>                                   17118000
                                                                        17120000
   CASE * FTYPE OF                                                      17122000
      BEGIN                                                             17124000
                                                                        17126000
      BEGIN    << conventional file >>                                  17128000
      IF IOQX <> 0 THEN                                                 17130000
         BEGIN          << No-wait I/O pending >>                       17132000
         TOS := IOPENDING;                                              17134000
         GO NFG                                                         17136000
         END;                                                           17138000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>17140000
         BEGIN      << out of bounds. >>                                17142000
         TOS := BNDVIOL;                                                17144000
         GO NFG                                                         17146000
         END;                                                           17148000
      IF ACB'ACCCL <> DIRACC OR ACB'SPOOLED THEN                        17150000
         BEGIN      << Must be disk. >>                                 17152000
         TOS := DEVVIOL;                                                17154000
         GO NFG                                                         17156000
         END;                                                           17158000
      IF NOT ACBUPDATE OR ACB'VARIABLE THEN                             17160000
         BEGIN      << Can't UPDATE. >>                                 17162000
         TOS := ACCVIOL;                                                17164000
         GO NFG                                                         17166000
         END;                                                           17168000
      IF ACB'FPTR <= 0D THEN                                            17170000
         BEGIN                                                          17172000
         TOS := FUPDSEQERR;                                             17174000
NFG:     ACB'ERROR := S0;                                               17176000
         TOS := CCL;                                                    17178000
         GO UNLK;                                                       17180000
         END;                                                           17182000
      TOS := IF ACB'NOWAIT THEN %31 ELSE 1;                             17186000
      IF ACB'INHIBITBUF THEN                                            17188000
         BEGIN         << NOBUF access >>                               17190000
         IF WC > ACBBSIZE THEN                                          17192000
            BEGIN       << More than one block is a no-no. >>           17194000
            TOS := BADTCOUNT;                                           17196000
            GO NFG                                                      17198000
            END;                                                        17200000
         ACB'FPTR := ACB'FPTR+1D-DOUBLE(ACB'BLKFACT);                   17202000
         END;                                                           17204000
      ACB'FPTR := ACB'FPTR-1D;                                          17206000
      IOMOVE(*,TARGET,TCOUNT);                                          17208000
      TOS := ACB'ERROR;                                                 17210000
      TOS := ACBSTATUSCODE;  << condition code to report >>             17212000
                                                                        17214000
      <<* * * Measurement data on FUPDATE * * *>>                       17216000
                                                                        17218000
$  IF X3 = ON                                                           17220000
      IF MEAS'TAPE'ON THEN BEGIN                                        17222000
      IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                    17224000
         BEGIN             << Measure. >>                               17226000
         TOS := EFUPDATE;      << event nr. >>                          17228000
         TOS := FILENUM;                                                17230000
         TOS.(0:1) := ACBHIT;  << buffer hit flag >>                    17232000
         MMSTAT(*,*,TCOUNT,0)                                           17234000
         END                                                            17236000
      END;    << of MEAS'TAPE'ON >>                                     17238000
$  IF                                                                   17240000
UNLK: UNLOC'ACB(10,0);    << release ACB >>                             17242000
      END;     << conventional file >>                                  17244000
                                                                        17246000
      BEGIN     << Remote file >>                                       17248000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>17250000
         BEGIN                                                 <<DS.04>>17252000
         LOCAL'FAILURE := BNDVIOL;                             <<DS.04>>17254000
         TCOUNT := 0;                                          <<DS.06>>17256000
         END;                                                  <<DS.04>>17258000
      SETRFAPTR;                                               <<DS.00>>17260000
      RFALEN := 5;                                             <<DS.00>>17262000
      TOS := "RFA ";                                           <<DS.00>>17264000
      IF RFAMREC THEN TOS := 28 ELSE TOS := 10;                <<DS.03>>17266000
      LOAD'ERROR;                                              <<DS.04>>17268000
      TOS := RFAFILE;                                          <<DS.00>>17270000
      TOS := TCOUNT;                                           <<DS.00>>17272000
      GETMWCPARMS;                                             <<DS.00>>17274000
      IF RFAMREC THEN TOS := 0D ELSE                           <<DS.03>>17276000
         BEGIN                                                 <<DS.03>>17278000
         TOS := @TARGET;                                       <<DS.03>>17280000
         TOS := TCOUNT;                                        <<DS.03>>17282000
         END;                                                  <<DS.03>>17284000
      TOS := 0D;                                               <<DS.00>>17286000
      TOS := MWCPLABEL;                                        <<DS.00>>17288000
      ASMB(PCAL 0);                                            <<DS.00>>17290000
      DEL;                                                     <<DS.00>>17292000
      CHECKXFER;                                               <<DS.00>>17294000
      IF RFAMREC THEN                                          <<DS.03>>17296000
         BEGIN     << Send data >>                             <<DS.03>>17298000
         RFALEN := 0;                                          <<DS.03>>17300000
         GETMWCPARMS;                                          <<DS.03>>17302000
         TOS := @TARGET;                                       <<DS.03>>17304000
         TOS := TCOUNT;                                        <<DS.03>>17306000
         TOS := 0D;                                            <<DS.03>>17308000
         TOS := MWCPLABEL;                                     <<DS.03>>17310000
         ASMB(PCAL 0);                                         <<DS.03>>17312000
         DEL;                                                  <<DS.03>>17314000
         CHECKXFER;                                            <<DS.03>>17316000
         RFALEN := 5;                                          <<DS.03>>17318000
         END;                                                  <<DS.03>>17320000
      DELAPPENDAGE;                                            <<DS.00>>17322000
      PREPRETURN;                                              <<DS.00>>17324000
      GO EXIT;                                                 <<DS.00>>17326000
      END;     << remote file >>                                        17328000
            << dummy 2 >>;                                              17330000
            << dummy 3 >>;                                              17332000
            << dummy 4 >>;                                              17334000
            << dummy 5 >>;                                              17336000
      BEGIN     << KSAM file >>                                         17338000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>17340000
         BEGIN      << out of bounds. >>                                17342000
         FKSAMBNDVIOL(FILENUM);                                <<KS.00>>17344000
         TOS := BNDVIOL;                                                17346000
         TOS := CCL;                                                    17348000
         GO EXIT;                                                       17350000
         END;                                                           17352000
      KUPDATE(FILENUM,TARGET,TCOUNT);                          <<KS.00>>17354000
      PUSH(STATUS);                                            <<KS.00>>17356000
      TOS := TOS.CC;      << report condition code >>          <<KS.00>>17358000
      ASMB(ZERO,XCH);                                          <<KS.00>>17360000
      END;       << KSAM file >>                               <<KS.00>>17362000
      <<DUMMY 7>>;                                             <<HM.00>>17364000
      BEGIN  <<MSG FILE>>                                      <<HM.00>>17366000
      TOS:=ACCVIOL;                                            <<HM.00>>17368000
      GO NFG;                                                  <<HM.00>>17370000
      END;                                                     <<HM.00>>17372000
      END; << FTYPE CASE >>                                    <<DS.00>>17374000
                                                                        17376000
EXIT:                                                                   17378000
   CONDCODE := TOS;    << report condition code >>                      17380000
   RESETCRITICAL(CRIT);                                                 17382000
   ERROREXIT(3,S0,0)                                                    17384000
   END;      << procedure FUPDATE >>                                    17386000
$PAGE " IOWAIT "                                                        17388000
$CONTROL SEGMENT = FILESYS2   << IOWAIT >>                              17390000
                                                                        17392000
INTEGER PROCEDURE IOWAIT(FILENUM,TARGET,TCOUNT,CSTATION);               17394000
VALUE FILENUM;                                                          17396000
INTEGER FILENUM,TCOUNT;                                                 17398000
LOGICAL CSTATION;                                                       17400000
ARRAY TARGET;                                                           17402000
OPTION VARIABLE,PRIVILEGED;                                             17404000
                                                                        17406000
<< Notice to users:                                                     17408000
   It is not possible to use the IOWAIT intrinsic with a                17410000
   KSAM/3000 file at this time because the developers                   17412000
   of this access method for the HP3000 have decided                    17414000
   that the concept of input-output without wait is not                 17416000
   consistent with the method of implementation of the                  17418000
   access method.  Sorry, Charlie.          >>                          17420000
                                                                        17422000
   BEGIN                                                                17424000
   DEFINE READ = NOT ACB'NOWAITMODE#,                                   17426000
          WRITE = ACB'NOWAITMODE#;                                      17428000
   DEFINE NOBUFSPEC = NOT (PMAP.(13:1))#;                      <<HM.00>>17430000
   ENTRY MIOWAIT;        << MAKRO - reset LEFTOFF to zero >>            17432000
   ENTRY IODONTWAIT;     << Don't wait for I/O completion >>            17434000
   ENTRY MIODONTWAIT;    << MAKRO - don't wait and reset LEFTOFF>>      17436000
   LOGICAL PMAP = Q-4;   << Option Variable bit map >>                  17438000
   EQUATE UBND = -10; << Q rel upper bound for bounds check>>  <<03059>>17440000
   INTEGER ERROR;            << error nr. for ERROREXIT >>              17442000
   INTEGER CRIT;             << for SETCRITICAL >>                      17444000
   INTEGER POINTER PXFILE;                                              17446000
   LOGICAL FLAGS;                                                       17448000
   DEFINE DONTWAIT = FLAGS.(14:1)#;  << don't wait for I/O >>           17450000
   INTEGER POINTER AFT;                                                 17452000
   DOUBLE POINTER AFTDBL = AFT;                                         17454000
   INTEGER ENTRYTYPE := -1;  << AFT entry type >>                       17456000
   DEFINE UNKNOWNENTRY = (ENTRYTYPE = -1)#,                             17458000
          FSENTRY      = (ENTRYTYPE = 0)#,                              17460000
          CSENTRY       = ( ENTRYTYPE&LSR(1) = 2)#,            <<00183>>17462000
          DSENTRY       = ( ENTRYTYPE&LSR(1) = 1)#,            <<00183>>17464000
          TTSENTRY      = ( ENTRYTYPE = 7)#,                   <<HM.00>>17466000
          MSGENTRY      = ( ENTRYTYPE = 8)#;                   <<HM.00>>17468000
                                                                        17470000
   DOUBLE IOCB;        << IOCB of completed I/O >>                      17472000
      INTEGER IOQSTATUS = IOCB,                                         17474000
              IOQTLOG = IOCB+1;                                         17476000
   INTEGER LDEV;        << LDEV on which I/O completed >>               17478000
   LOGICAL STATION := 0;  << CS station of completed I/O>>              17480000
   INTEGER TRANSLOG := 0;                                               17482000
   INTEGER I,COMP'IOQINDEX,NUM'IOQINDICES;                     <<00613>>17484000
   INTEGER ARRAY IOQINDEX(0:13)=Q;                             <<HM.00>>17486000
   EQUATE CS'ERRORLOC =  5;   << PXFILE location >>            <<00613>>17488000
   EQUATE                                                      <<HM.00>>17490000
      DUMMY'TLOG      = -1,  << Use for file system kludge. >> <<04567>>17492000
      NO'WAIT'DONE    = -1,                                    <<HM.00>>17494000
      SOFTINTPEND     = -2,                                    <<03038>>17496000
      SOFTINTOCCURRED = -3,                                    <<03038>>17498000
      IOCOMPLETION    = 1,                                     <<03038>>17500000
      PORT'WAIT       = -4,                                    <<HM.00>>17502000
      LONG'WAIT       = 1;                                     <<HM.00>>17504000
INTEGER ACBMQ;                                                 <<04567>>17506000
                                                                        17508000
<< Following LOC'ACB params must be last and in order: >>               17510000
   INTEGER AFTE;      << AFT entry word 0 >>                            17512000
   INTEGER PACBV;                                                       17514000
   INTEGER LACBV;                                                       17516000
   INTEGER IOQX;      << IOQX of completed I/O >>                       17518000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;                        <<HM.00>>17520000
   INTEGER ACB'ERROR    = ACB+14;                                       17522000
   INTEGER ACB'TLOG     = ACB+15;                                       17524000
   LOGICAL ACB'STATW    = ACB+29;                                       17526000
   LOGICAL ACB'GSTW     = ACB+30;                                       17528000
   INTEGER DSTX;      << DST of user's buffer >>                        17530000
                                                                        17532000
   SUBROUTINE IOEXIT(FCERROR);                                          17534000
   << Inserts the specified error number in the PXFILE area or          17536000
     ACB and does the ERROREXIT from the IOWAIT procedure.              17538000
                                                                        17540000
        Input variables:                                                17542000
            FCERROR - FS/CS error number                                17544000
                                                                        17546000
      May be called with DB at any data segment.    >>                  17548000
   VALUE FCERROR;                                                       17550000
   INTEGER FCERROR;                                                     17552000
      BEGIN                                                             17554000
      IF FCERROR = SOFTINTOCCURRED THEN                        <<03038>>17556000
         BEGIN  <<SOFT INT, FORCE USER TO RECALL IOWAIT>>      <<03038>>17558000
         PREGISTER:=PREGISTER-1;                               <<03038>>17560000
         PREGISTER.(0:1):=1;                                   <<03038>>17562000
         IF DSTX <> 0 THEN EXCHANGEDB(DSTX);                   <<03038>>17564000
         RESETCRITICAL(CRIT);                                  <<03038>>17566000
         ERROREXIT(0,0,0);                                     <<03038>>17568000
         END;                                                  <<03038>>17570000
      IF UNKNOWNENTRY THEN                                              17572000
         BEGIN    << AFT type unknown. Post nr. in PXFILE >>            17574000
         EXCHANGEDB(0);   << Set DB to stack >>                         17576000
         SETPXFILE;      << init. PXFILE pointer >>                     17578000
         PXFFOPEN := FCERROR;                                           17580000
         PXFDOPEN := FCERROR;                                           17582000
         PXFCOPEN := FCERROR                                            17584000
         END                                                            17586000
      ELSE IF CSENTRY THEN      << CS line referenced? >>      <<00613>>17588000
         BEGIN     << Save CS error in MISC'DST for AFT entry>><<00613>>17590000
         EXCHANGEDB(0);       << Set DB to stack >>            <<00613>>17592000
         TOS := @FCERROR;   << S-rel addr before TOS moves>>   <<00613>>17594000
         TOS := AFTCS'MDST;                                    <<00613>>17596000
         TOS := CS'ERRORLOC;                                   <<00613>>17598000
         ASMB(CAB);       << FCERROR address to TOS >>         <<00613>>17600000
         TOS := 1;          << word count >>                   <<00613>>17602000
         ASMB(MTDS);                                           <<00613>>17604000
         END                                                   <<00613>>17606000
      ELSE IF FSENTRY OR MSGENTRY THEN                         <<HM.00>>17608000
         BEGIN      << Set ACBERROR. >>                                 17610000
         LOC'ACB(0,ACBMQ,FILENUM,UMODE);                       <<HM.00>>17612000
         DEL;      << discard DSTX >>                                   17614000
         ACB'ERROR := FCERROR;                                          17616000
         UNLOC'ACB(ACBMQ,0);                                   <<HM.00>>17618000
         END;                                                           17620000
      ERROR := FCERROR;                                                 17622000
      IF DSTX <> 0 THEN EXCHANGEDB(DSTX);                      <<03038>>17624000
      RESETCRITICAL(CRIT);                                              17626000
      CONDCODE := CCL;                                                  17628000
      ERROREXIT(5,ERROR,0)                                              17630000
      END;      << subroutine IOEXIT >>                                 17632000
                                                                        17634000
   SUBROUTINE SETWAKE'(INDEX);                                 <<HM.00>>17636000
   VALUE INDEX;                                                <<HM.00>>17638000
   INTEGER INDEX;                                              <<HM.00>>17640000
      BEGIN                                                    <<HM.00>>17642000
      IF AFTMSGTYPE THEN                                       <<HM.00>>17644000
         BEGIN                                                 <<01568>>17646000
         IF INDEX = NO'WAIT'DONE THEN                          <<01568>>17648000
            BEGIN  <<IO COMPLETED AT INITIATION TIME>>         <<01568>>17650000
            TOS:=-1; DEL;  <<FORCE CCL STATUS>>                <<01568>>17652000
            END                                                <<01568>>17654000
         ELSE                                                  <<01568>>17656000
            FCPORTENABLE(INDEX);                               <<03038>>17658000
         END                                                   <<01568>>17660000
      ELSE                                                     <<HM.00>>17662000
         SETWAKE(INDEX);                                       <<HM.00>>17664000
      END;  <<SETWAKE'>>                                       <<HM.00>>17666000
   SUBROUTINE CLEARWAKE'(INDEX);                               <<HM.00>>17668000
   VALUE INDEX;                                                <<HM.00>>17670000
   INTEGER INDEX;                                              <<HM.00>>17672000
      BEGIN                                                    <<HM.00>>17674000
      IF AFTMSGTYPE THEN                                       <<HM.00>>17676000
         FCPORTDISABLE(INDEX)                                  <<HM.00>>17678000
      ELSE                                                     <<HM.00>>17680000
         CLEARWAKE(INDEX);                                     <<HM.00>>17682000
      END;  <<CLEARWAKE'>>                                     <<HM.00>>17684000
   DOUBLE SUBROUTINE WAITFORIOX'(IOQX);                        <<HM.00>>17686000
   VALUE IOQX;                                                 <<HM.00>>17688000
   INTEGER IOQX;                                               <<HM.00>>17690000
      BEGIN                                                    <<HM.00>>17692000
      IF AFTMSGTYPE THEN                                       <<HM.00>>17694000
         BEGIN  <<PORT WAIT, ALLOW ABORT>>                     <<HM.00>>17696000
         RESETCRITICAL(0);                                     <<HM.00>>17698000
         WHILE NOT FCPORTENABLE(IOQX) DO                       <<HM.00>>17700000
            BEGIN  <<WAIT FOR I/O OR SOFT INTERRUPT>>          <<03038>>17702000
            WAIT(PORT'WAIT,%10001);                            <<03038>>17704000
            IF > THEN                                          <<03038>>17706000
               BEGIN  <<SOFT INTERRUPT OCCURRED>>              <<03038>>17708000
               SETCRITICAL;                                    <<03038>>17710000
               CLEARWAKE'(IOQX);                               <<03038>>17712000
               IOEXIT(SOFTINTOCCURRED);                        <<03038>>17714000
               END;                                            <<03038>>17716000
            END;                                               <<03038>>17718000
         SETCRITICAL;                                          <<HM.00>>17720000
         END                                                   <<HM.00>>17722000
      ELSE                                                     <<HM.00>>17724000
         BEGIN                                                 <<HM.00>>17726000
         WAITFORIOX':=WAITFORIOX(IOQX);                        <<HM.00>>17728000
$IF X1=ON                                                      <<HM.00>>17730000
         IF <> THEN FTROUBLE(487);                             <<HM.00>>17732000
$IF                                                            <<HM.00>>17734000
         END;                                                  <<HM.00>>17736000
      END;  <<WAITFORIOX'>>                                    <<HM.00>>17738000
   SUBROUTINE CHECK'CS'IOQINDICES;                             <<00613>>17740000
      << Check the multiple CS IOQ indices for completion. >>           17742000
      << Completed IOQ index is stored in the CS AFTIOQX. >>            17744000
      BEGIN                                                             17746000
      NUM'IOQINDICES :=                                                 17748000
         GET'CS'IOQINDICES(AFTCS'MDST,AFTCSIOQCBV,IOQINDEX);            17750000
      IF NUM'IOQINDICES = 0 THEN RETURN;  << None outstanding>>         17752000
   << Check each IOQ index for completion. >>                           17754000
      CLEARWWS;                                                         17756000
      I := -1;                                                          17758000
      COMP'IOQINDEX := 0;                                               17760000
                                                                        17762000
         DO                                                             17764000
            BEGIN                                                       17766000
            DO                                                          17768000
               BEGIN                                                    17770000
               I := I + 1;                                              17772000
               SETWAKE(IOQINDEX(I));                                    17774000
               IF < THEN   <<I/O complete >>                            17776000
                  COMP'IOQINDEX := IOQINDEX(I);                         17778000
               END                                                      17780000
            UNTIL COMP'IOQINDEX <> 0 OR I = NUM'IOQINDICES-1;           17782000
                                                                        17784000
         IF COMP'IOQINDEX = 0 AND NOT DONTWAIT THEN                     17786000
            WAIT(-%100,0);                                              17788000
                                                                        17790000
         DO                                                             17792000
            BEGIN                                                       17794000
            CLEARWAKE(IOQINDEX(I));                                     17796000
            IF < THEN       << I/O complete >>                          17798000
               COMP'IOQINDEX := IOQINDEX(I);                            17800000
            END                                                         17802000
         UNTIL (I:=I-1) < 0;                                            17804000
         END      << END DO UNTIL COMP'IOQINDEX <> 0 >>                 17806000
      UNTIL COMP'IOQINDEX <> 0 OR DONTWAIT;                             17808000
                                                                        17810000
      AFTIOQX := COMP'IOQINDEX; <<completed IOQINDEX into AFT>>         17812000
   << Must show I/O PENDING >>                                 <<01165>>17814000
      IF = THEN AFTIOQX := IOQINDEX;                           <<01165>>17816000
      END;    << subroutine CHECK'CS'IOQINDICES >>             <<01165>>17818000
                                                                        17820000
<< * * *  Begin execution  * * * >>                                     17822000
                                                                        17824000
$  IF X0 = ON                                                           17826000
   IF MONCALLABLE THEN                                                  17828000
      BEGIN        << monitoring >>                                     17830000
      FTITLE("IOWA","IT  ",0D,0D);                                      17832000
      DEBUG                                                             17834000
      END;                                                              17836000
$  IF                                                                   17838000
                                                                        17840000
   TOS := %(2)00;   << normal call >>                                   17842000
   GO CONT;                                                             17844000
MIOWAIT:                                                                17846000
   TOS := %(2)01;   << reset LEFTOFF >>                                 17848000
   GO CONT;                                                             17850000
IODONTWAIT:                                                             17852000
   TOS := %(2)10;  << Don't wait for I/O completion >>                  17854000
   GO CONT;                                                             17856000
   HELP;    << dummy call >>                                   <<00117>>17858000
MIODONTWAIT:                                                            17860000
   TOS := %(2)11;  << Reset LEFTOFF and don't wait >>                   17862000
CONT:                                                                   17864000
   FLAGS := TOS;   << special action flags >>                           17866000
                                                                        17868000
   ERRORON;                                                    <<00685>>17870000
   CRIT := SETCRITICAL;                                        <<00685>>17872000
   GET'ACB'Q'LOC;                                              <<04567>>17874000
   IOWAIT := 0;                                                         17876000
   DSTX := PCB'XDS;  << user's DST nr. - 0 if stack >>                  17878000
                                                                        17880000
   <<* * * Bounds check parameters * * *>>                              17882000
                                                                        17884000
   TOS := PMAP;           << OPTION-VARIABLE bit map >>                 17886000
   IF LS0.(15:1) THEN       << CSTATION specified? >>                   17888000
      IF FBNDVIOL(@CSTATION,1,UBND) THEN IOEXIT(BNDVIOL);      <<03059>>17890000
   IF LS0.(14:1) THEN       << TCOUNT specified? >>                     17892000
      IF FBNDVIOL(@TCOUNT,1,UBND) THEN IOEXIT(BNDVIOL);        <<03059>>17894000
                                                                        17896000
   <<* * * Get AFT address of completed I/O * * *>>                     17898000
                                                                        17900000
   IF NOT LS0.(12:1) OR FILENUM = 0 THEN                                17902000
      BEGIN         << Pick up any completed I/O. >>                    17904000
      FINDWAITINGIO(0,DUM,FLAGS);  << try to find one >>                17906000
      <<DB has now been set to the stack>>                     <<03038>>17908000
      IF > THEN IOEXIT(SOFTINTOCCURRED);                       <<03038>>17910000
      IF < THEN IOEXIT(NOIOPENDING1);     << warn't none. >>            17912000
      @AFT := TOS;           << AFT entry pointer >>                    17914000
      FILENUM := TOS;        << file or line nr. >>                     17916000
      IF FILENUM = 0 THEN                                               17918000
         BEGIN               << IODONTWAIT >>                           17920000
AOK:     EXCHANGEDB(DSTX);   << restore user's DB >>                    17922000
         CONDCODE := CCE;    << report OK >>                            17924000
         GO EXIT                                                        17926000
         END                                                            17928000
      END                                                               17930000
   ELSE                                                                 17932000
      BEGIN            << Inquiry about specific file. >>               17934000
      IF DSTX <> 0 THEN EXCHANGEDB(0);     << Set DB to stack>><<HM.00>>17936000
      SETPXFILE;          << Init. PXFILE pointer >>                    17938000
      IF NOT (1 <= FILENUM <= PXFAFTSIZE/AFTENTRY) THEN                 17940000
E1:      IOEXIT(INVFN);       << Invalid. >>                            17942000
      IF (FILENUM <= 2) AND NOT STATUS.(0:1) THEN GO E1;                17944000
      SETAFT;         << Init. AFT entry pointer >>                     17946000
      IF NOT AFTDSKLUDGE OR (AFTDBL = 0D) THEN GO E1;                   17948000
      IF AFTMSGTYPE AND AFTIOQX = SOFTINTPEND THEN             <<03038>>17950000
         BEGIN  <<SOFTWARE INTERRUPT PENDING>>                 <<03038>>17952000
         IOQX:=AFTIOQX;                                        <<03038>>17954000
         IOEXIT(NOIOPENDING2);                                 <<03038>>17956000
         END;                                                  <<03038>>17958000
      IF AFTCSTYPE AND (AFTCSIOQCBV <> 0) THEN                 <<00613>>17960000
         CHECK'CS'IOQINDICES;    << Check multiple CS IOQS >>  <<00613>>17962000
                                                               <<04567>>17964000
         << Don't check status if IOQX < 0.  The IOQX was   >> <<04567>>17966000
         << put there as a file system kludge.  It is there >> <<04567>>17968000
         << simply as a stub for the user.                  >> <<04567>>17970000
                                                               <<04567>>17972000
      IF DONTWAIT AND AFTIOQX > 0 THEN                         <<04567>>17974000
         BEGIN                                                          17976000
         SETWAKE'(AFTIOQX);  <<CHECK FOR I/O COMPLETION>>      <<HM.00>>17978000
         IF = THEN                                                      17980000
            BEGIN          << I/O not completed. >>                     17982000
            CLEARWAKE'(AFTIOQX);  <<RESET WAKE BIT>>           <<HM.00>>17984000
            GO AOK                                                      17986000
            END                                                         17988000
         END                                                            17990000
      END;            << specific file >>                               17992000
   DEL;  <<DELETE THE PMAP>>                                   <<HM.00>>17994000
   ENTRYTYPE := AFTTYPE;     << AFT entry type >>                       17996000
   IOQX := AFTIOQX;                                                     17998000
   LDEV := AFTLDEV;                                                     18000000
                                                                        18004000
   <<*******************************************************>> <<04567>>18006000
   << Obtain IOCB of completed I/O.  If the IOQX is less    >> <<04567>>18008000
   << then zewro, than this is a dummy stub put there by    >> <<04567>>18010000
   << the file system.  Use the TLOG already in the ACB     >> <<04567>>18012000
   << when calling IOMOVE.                                  >> <<04567>>18014000
   <<*******************************************************>> <<04567>>18016000
                                                               <<04567>>18018000
                                                                        18020000
   IF IOQX = 0 THEN IOEXIT(NOIOPENDING2);                               18022000
   IF IOQX > 0 THEN                                                     18024000
      BEGIN               << Real IOQX >>                               18026000
      IOCB := WAITFORIOX'(IOQX);  <<GET IOCB AND CS STATION>>  <<HM.00>>18028000
      STATION := X         << CS station >>                             18030000
      END                                                               18032000
   ELSE     << Dummy IOQX for file system >>                            18034000
      BEGIN                                                             18036000
      IF CSENTRY THEN FTROUBLE(911);  <<CS request?>>       <<00613>>   18038000
      IOQSTATUS := 1;       << Successful I/O >>               <<04567>>18040000
      IOQTLOG := DUMMY'TLOG;                                   <<04567>>18042000
      END;                                                              18044000
                                                                        18046000
   <<* * * Complete I/O request * * *>>                                 18048000
                                                                        18050000
   AFTIOQX:=0;                                                 <<03038>>18052000
   IF DSTX <> 0 THEN EXCHANGEDB(DSTX);      << Restore original  HM.00>>18054000
   IF CSENTRY THEN                                                      18056000
      BEGIN               << CS line responded >>                       18058000
      EXCHANGEDB(0);      << set DB to stack >>                         18060000
      AFTIOQX := IOQX;    << CSIOWAIT needs IOQINDEX >>        <<00613>>18062000
      TOS := 0D;         << set up call to CSIOWAIT >>                  18064000
      TOS := DSTX;                                                      18066000
      TOS := @AFT;                                                      18068000
      TOS := IOCB;                                                      18070000
      TOS := PMAP;                                                      18072000
      TOS := NOT FBNDVIOL(@TARGET,IOQTLOG,UBND) LAND           <<03059>>18074000
             PMAP.(13:1);                                      <<03059>>18076000
      TOS := @STATUS;                                                   18078000
      TOS := @TARGET;                                                   18080000
      TOS := ABSOLUTE(CSIOWAIT);   << CSIOWAIT P-label >>               18082000
      IF = THEN FTROUBLE(777);  << CSIOWAIT not in system.>>            18084000
      ASMB(PCAL 0);                                                     18086000
      TRANSLOG := TOS;     << DB now points to DSTX >>                  18088000
      ERROR := TOS                                                      18090000
      END       << CS line >>                                           18092000
   ELSE IF AFTMSGTYPE THEN                                     <<HM.00>>18094000
      BEGIN  <<MESSAGE FILE>>                                  <<HM.00>>18096000
      LOC'ACB(*,ACBMQ,FILENUM,UMODE);                          <<HM.00>>18098000
      IF ACBREAD THEN                                          <<HM.00>>18100000
         BEGIN                                                 <<HM.00>>18102000
         IF NOBUFSPEC THEN                                     <<HM.00>>18104000
            BEGIN                                              <<HM.00>>18106000
            ACBERROR:=OMITTEDPARM;                             <<HM.00>>18108000
            ACBTLOG:=0;                                        <<HM.00>>18110000
            TOS:=CCL; TOS:=0;                                  <<03038>>18112000
            END                                                <<HM.00>>18114000
         ELSE                                                  <<HM.00>>18116000
            FCREAD(IOCOMPLETION,TARGET,0)                      <<HM.00>>18118000
         END                                                   <<HM.00>>18120000
      ELSE                                                     <<HM.00>>18122000
         FCWRITE(IOCOMPLETION,DUM,0);                          <<01898>>18124000
      UNLOC'ACB(ACBMQ,0);                                      <<HM.00>>18126000
      IF S0 <> 0 THEN FCAWAKEN(*) ELSE DEL;                    <<03038>>18128000
      CONDCODE:=TOS;                                           <<HM.00>>18130000
      TRANSLOG:=ACBTLOG;                                       <<HM.00>>18132000
      ERROR:=ACBERROR;                                         <<HM.00>>18134000
      END                                                      <<HM.00>>18136000
   ELSE IF FSENTRY THEN                                                 18138000
      BEGIN      << Conventional FS file responded >>                   18140000
      LOC'ACB(*,ACBMQ,FILENUM,UMODE);  << get ACB >>           <<HM.00>>18142000
                                                               <<04567>>18144000
      << For the dummy IOQX case, leave the ACB'TLOG as it  >> <<04567>>18146000
      << was.  The proper value was already there.          >> <<04567>>18148000
                                                               <<04567>>18150000
      IF IOQTLOG <> DUMMY'TLOG                                 <<04567>>18152000
         THEN ACB'TLOG := IOQTLOG;                             <<04567>>18154000
      ACB'STATUS := IOQSTATUS; << Set I/O status >>            <<04567>>18156000
      TOS := %40+ACB'NOWAITMODE;  << complete I/O >>                    18158000
      TOS := @TARGET;      << for :EOD test only >>                     18160000
      TOS := ACB'TLOG;    << TCOUNT - for sign >>              <<01698>>18162000
      IOMOVE(*,*,*);         << Complete the I/O >>                     18164000
      IF ACB'GSTATUS = 1 THEN                                           18166000
         BEGIN          << Successful I/O. >>                           18168000
         IF ACB'ERROR = TAPERREC OR  <<recovered tape error?>>          18170000
            READ AND (ACB'ERROR = EOL) OR  <<EOL after read?>>          18172000
            WRITE AND (ACB'ERROR = EOT) THEN  <<EOT after W?>>          18174000
            TOS := CCL    << report error >>                            18176000
         ELSE       << Really OK >>                                     18178000
            TOS := CCE                                                  18180000
         END                                                            18182000
      ELSE       << I/O error. >>                                       18184000
         TOS := ACBSTATUSCODE;  << Report condition code >>             18186000
                                                                        18188000
      <<* * * Measure data on IOWAIT * * *>>                            18190000
                                                                        18192000
$  IF X3 = ON                                                           18194000
      IF MEAS'TAPE'ON THEN BEGIN                                        18196000
      IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                    18198000
         BEGIN      << Measure >>                                       18200000
         TOS := EIOWAIT;       << event nr. >>                          18202000
         TOS := FILENUM;                                                18204000
         TOS.(0:1) := ACBHIT;  << buffer hit flag >>                    18206000
         MMSTAT(*,*,ACB'TLOG,0)                                         18208000
         END;                                                           18210000
      END; << OF MEAS'TAPE'ON>>                                         18212000
$  IF                                                                   18214000
                                                                        18216000
      CONDCODE := TOS;     << report condition code >>                  18218000
      TRANSLOG := ACB'TLOG;                                             18220000
      ERROR := ACB'ERROR;                                               18222000
      UNLOC'ACB(ACBMQ,0);     << release ACB >>                <<HM.00>>18224000
      END        << conventional file >>                                18226000
   ELSE IF DSENTRY THEN                                        <<00183>>18228000
      BEGIN      << DS line responded. >>                               18230000
      TOS := IOCB;       << TLOG and status >>                          18232000
      TRANSLOG := TOS;                                                  18234000
      IF S0.(8:8) = 1 THEN TOS.(15:1) := 0;  << no error. >>   <<DS.06>>18236000
      ERROR := TOS;      << I/O status >>                               18238000
      CONDCODE := IF ERROR.(8:8) = 0 THEN CCE ELSE CCL                  18240000
      END                                                               18242000
   ELSE IF TTSENTRY THEN                                       <<00183>>18244000
      BEGIN     << 3270 I/O completed. >>                      <<00183>>18246000
      TOS := 0;        << for result of TRANSLATE ERROR call >><<00183>>18248000
      TOS := 2;        << select ERROR TRANSLATE function >>   <<00421>>18250000
      TOS := IOCB;     << TLOG and status >>                   <<00421>>18252000
      TRANSLOG := TOS;    << count >>                          <<00421>>18254000
      TOS := PLABEL3270;                                       <<01165>>18256000
      IF = THEN FTROUBLE(53);    << 3270 not installed. >>     <<01910>>18258000
      ASMB(PCAL 0);    << STATION := PLABEL3270(STATUS,2); >>  <<00183>>18260000
      STATION := TOS;                                          <<00183>>18262000
      ERROR := 0;      << Always OK >>                         <<00183>>18264000
      CONDCODE := IF STATION = 0 THEN CCE ELSE CCL;            <<00183>>18266000
      END;                                                     <<00183>>18268000
                                                                        18270000
   <<* * * Return parameters to caller * * *>>                          18272000
                                                                        18274000
   IOWAIT := FILENUM;     << file/line nr. responding >>                18276000
   IF PMAP.(14:1) THEN TCOUNT := \TRANSLOG\;                            18278000
   IF PMAP THEN CSTATION := STATION;  << CS station responding >>       18280000
                                                                        18282000
EXIT:                                                                   18284000
   RESETCRITICAL(CRIT);                                                 18286000
   ERROREXIT(5,ERROR,0)                                                 18288000
   END;            << procedure IOWAIT >>                               18290000
$PAGE " FREADSEEK "                                                     18292000
$CONTROL SEGMENT = FILESYS2   << FREADSEEK >>                           18294000
PROCEDURE FREADSEEK(FILENUM,REC);                              <<KS.00>>18296000
VALUE FILENUM,REC;                                                      18298000
INTEGER FILENUM;                                                        18300000
DOUBLE REC;                                                             18302000
OPTION PRIVILEGED;                                                      18304000
   BEGIN                                                                18306000
   INTEGER POINTER AFT;      << for KSAM >>                    <<KS.00>>18308000
   DOUBLE SAVE'FPTR;      << for ACB'FPTR >>                            18310000
   INTEGER CRIT;        << for SETCRITICAL >>                           18312000
                                                                        18314000
   << Remote file access (RFA) variables: >>                            18316000
                                                                        18318000
   INTEGER POINTER RFAPTR;     << appendage pointer >>                  18320000
   INTEGER RFALEN;             << appendage length >>                   18322000
                                                               <<DS.00>>18324000
<< Following LOC'ACB params must be last and in order: >>               18326000
   INTEGER AFTE;       << AFT entry word 0 >>                           18328000
   INTEGER PACBV;                                                       18330000
   INTEGER LACBV;                                                       18332000
   INTEGER IOQX;                                                        18334000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+11 >>                   18336000
   BUILD'ACB;                                                           18338000
   LOGICAL DSTX;      << DST nr. of user's buffer >>                    18340000
<< end of LOCACB params >>                                              18342000
                                                                        18344000
$  IF X0 = ON                                                           18346000
   IF MONCALLABLE THEN                                                  18348000
      BEGIN       << monitoring >>                                      18350000
      FTITLE("FREA","DSEE","K   ",0D);                                  18352000
      DEBUG                                                             18354000
      END;                                                              18356000
$  IF                                                                   18358000
                                                                        18360000
   ERRORON;                                                             18362000
   CRIT := SETCRITICAL;                                                 18364000
   LOC'ACB(*,11,FILENUM,UMODE);   << get ACB >>                         18366000
   IF < THEN                                                            18368000
      BEGIN         << Invalid file number. >>                          18370000
      TOS := INVFN;                                                     18372000
      TOS := CCL;                                                       18374000
      GO EXIT                                                           18376000
      END;                                                              18378000
   IF > THEN                                                            18380000
      BEGIN          << File is $NULL >>                                18382000
      TOS := 0;      << No error >>                                     18384000
      TOS := CCE;                                                       18386000
      GO EXIT                                                           18388000
      END;                                                              18390000
   CASE * FTYPE OF                                                      18392000
   BEGIN                                                                18394000
                                                                        18396000
   BEGIN     << conventional file >>                                    18398000
   IF IOQX <> 0 THEN                                                    18400000
      BEGIN           << No-wait I/O pending. >>                        18402000
      TOS := IOPENDING;                                                 18404000
      GO NFG                                                            18406000
      END;                                                              18408000
   IF ACB'ACCCL <> DIRACC OR ACB'SPOOLED THEN                           18410000
      BEGIN         << FREADSEEK invalid unless disk file. >>           18412000
      TOS := DEVVIOL;                                                   18414000
      GO NFG                                                            18416000
      END;                                                              18418000
   IF ACB'VARIABLE OR ACB'INHIBITBUF OR (1 <= ACB'ACTYPE <= 3) THEN     18420000
      BEGIN                                                             18422000
      TOS := ACCVIOL;                                                   18424000
NFG:  ACB'ERROR := S0;                                                  18426000
      TOS := CCL;         << error condition code >>                    18428000
      GO UNLK;                                                          18430000
      END;                                                              18432000
   SAVE'FPTR := ACB'FPTR;                                               18434000
   ACB'FPTR := REC;                                                     18436000
   IOMOVE(%10,DUM,0);      << start the read. >>                        18438000
   ACB'FPTR := SAVE'FPTR;                                               18440000
   TOS := ACB'ERROR;        << error nr. >>                             18442000
   TOS := ACBSTATUSCODE;    << condition code to report >>              18444000
                                                                        18446000
   <<* * * Measurement data on FREADSEEK * * *>>                        18448000
                                                                        18450000
$  IF X3 = ON                                                           18452000
   IF MEAS'TAPE'ON THEN BEGIN                                           18454000
   IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                       18456000
      BEGIN       << measure >>                                         18458000
      TOS := EFREADSEEK;    << event nr. >>                             18460000
      TOS := FILENUM;       << file nr. >>                              18462000
      TOS.(0:1) := ACBHIT;  << buffer hit flag >>                       18464000
      TOS := REC;           << record nr. >>                            18466000
      MMSTAT(*,*,*,*)      << measure event >>                          18468000
      END;                                                              18470000
   END;       << of MEAS'TAPE'ON>>                                      18472000
$  IF                                                                   18474000
                                                                        18476000
UNLK:                                                                   18478000
   UNLOC'ACB(11,0);    << release ACB >>                                18480000
   END;       << conventional file >>                                   18482000
                                                                        18484000
   BEGIN      << remote file >>                                <<DS.00>>18486000
   SETRFAPTR;                                                  <<DS.00>>18488000
   RFALEN := 6;                                                <<DS.00>>18490000
   TOS := "RFA ";                                              <<DS.00>>18492000
   TOS := 5;                                                   <<DS.04>>18494000
   TOS := RFAFILE;                                             <<DS.00>>18496000
   TOS := REC;                                                 <<DS.00>>18498000
   MWCNOBUF;                                                   <<DS.00>>18500000
   CHECKXFER;                                                  <<DS.00>>18502000
   DELAPPENDAGE;                                               <<DS.00>>18504000
   PREPRETURN;                                                 <<DS.00>>18506000
   END;     << remote file >>                                           18508000
                                                                        18510000
      << dummy 2 >>;                                                    18512000
      << dummy 3 >>;                                                    18514000
      << dummy 4 >>;                                                    18516000
      << dummy 5 >>;                                                    18518000
   BEGIN        << KSAM file >>                                         18520000
   DSTX := EXCHANGEDB(0);      << to stack >>                  <<KS.00>>18522000
   SETAFT;                                                     <<KS.00>>18524000
   AFTFLAG := 3;   << KSAM error. >>                           <<KS.00>>18526000
   AFTERRNUM := UNIMPL;    <<"Unimplemented">>                 <<KS.00>>18528000
   TOS := UNIMPL;          << "Unimplemented" >>               <<KS.00>>18530000
   TOS := CCL;                                                 <<KS.00>>18532000
   EXCHANGEDB(DSTX);       << restore >>                       <<KS.00>>18534000
   END;       << KSAM >>                                       <<KS.00>>18536000
   <<DUMMY 7>>;                                                <<HM.00>>18538000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>18540000
   TOS:=ACCVIOL;                                               <<HM.00>>18542000
   GO NFG;                                                     <<HM.00>>18544000
   END;                                                        <<HM.00>>18546000
   END;       << FTYPE CASE >>                                 <<DS.00>>18548000
                                                                        18550000
EXIT:                                                                   18552000
   CONDCODE := TOS;    << report condition code >>                      18554000
   RESETCRITICAL(CRIT);                                                 18556000
   ERROREXIT(3,S0,0)                                                    18558000
   END;       << procedure FREADSEEK >>                                 18560000
$PAGE " FSPACE "                                                        18562000
$CONTROL SEGMENT = FILESYS2   << FSPACE >>                              18564000
PROCEDURE FSPACE(FILENUM,DSPL);                                         18566000
VALUE FILENUM,DSPL;                                                     18568000
INTEGER FILENUM,DSPL;                                                   18570000
OPTION PRIVILEGED;                                                      18572000
   BEGIN                                                                18574000
   INTEGER CRIT;     << for SETCRITICAL >>                              18576000
   INTEGER ERR;      << error nr. >>                                    18578000
   INTEGER I;                                                           18580000
      LOGICAL LI = I;                                          <<02545>>18582000
   DOUBLE NEWPOS;                                                       18584000
                                                                        18586000
   << Remote file access (RFA) variables: >>                   <<DS.00>>18588000
                                                                        18590000
   INTEGER POINTER RFAPTR;    << appendage pointer >>          <<DS.00>>18592000
   INTEGER RFALEN;            << appendage length >>           <<DS.00>>18594000
                                                                        18596000
<< Following LOC'ACB params must be last and in order: >>               18598000
   INTEGER ACBMQ;                                              <<04591>>18600000
   INTEGER AFTE;      << AFT entry word 0 >>                            18602000
   INTEGER PACBV;                                                       18604000
   INTEGER LACBV;                                                       18606000
   INTEGER IOQX;                                                        18608000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q + ACBMQ >>     <<04591>>18610000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        18612000
   BUILD'ACB;                                                           18614000
   LOGICAL DSTX;     << DST nr. of user's buffer >>                     18616000
<< End of LOC'ACB params >>                                             18618000
                                                                        18620000
SUBROUTINE ATTIO(FUNC);                                        <<02693>>18624000
VALUE FUNC; INTEGER FUNC;                                      <<02693>>18626000
   << Shortcut to call ATTACHIO. >>                            <<02693>>18628000
                                                               <<02693>>18630000
   BEGIN                                                       <<02693>>18632000
   TOS := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,0,4,BFLAGS);         <<02693>>18634000
   ASMB(DEL,DUP);                                              <<02693>>18636000
   IF TOS.(8:8) <> 1 THEN                                      <<02693>>18638000
      BEGIN         << ATTACHIO reports error. >>              <<02693>>18640000
      ASMB(ZERO,XCH);    << for result of IOSTAT >>            <<02693>>18642000
      TOS := IOSTAT(*);                                        <<02693>>18644000
      ASMB(TEST);                                              <<02693>>18646000
      IF <> AND S0 <> EOT AND S0 <> TAPERREC THEN GO NFG;      <<02712>>18648000
      END;                                                     <<02693>>18650000
   DEL;                                                        <<02693>>18652000
   END;            << subroutine ATTIO >>                      <<02693>>18654000
   SUBROUTINE TAPEFUNC(FUNC);                                  <<02693>>18656000
      << Performs the specified mag tape function.                      18658000
        Input variables:                                                18660000
            FUNC - ATTACHIO function. 11=FSR, 12=BSR.                   18662000
      >>                                                                18666000
   VALUE FUNC; INTEGER FUNC;                                   <<02693>>18668000
                                                               <<02693>>18670000
      BEGIN   << Do function, wait for completion >>                    18672000
      TOS := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,0,0,BFLAGS);      <<02693>>18674000
      IF S1STAT <> 1 THEN                                               18676000
         BEGIN    << Woops! Error. >>                                   18678000
         IF ACB'LABELLED AND S1STAT=EOFSTAT THEN               <<00901>>18680000
            BEGIN      << Handle EOF on labeled tape. >>       <<02545>>18682000
            IF S3 = 12 THEN    << BSR >>                       <<02693>>18684000
              ATTIO(11)     << FSR over TM: stay in data >>    <<02545>>18686000
            ELSE               << FSR >>                       <<02545>>18688000
              BEGIN     << FSR at EOF/EOV. Seek next volume >> <<02545>>18690000
              REELSWITCH(ACB'DADDR,0);                         <<02545>>18692000
              IF < THEN S1 := NAVLSTAT ELSE IF = THEN          <<02545>>18694000
                BEGIN       << Switched reels. Position >>     <<02545>>18696000
                ACBBTFRCT := 0D;                               <<02545>>18698000
                TAPEFUNC(11);   << FSR over 1st record. >>     <<02693>>18702000
                GO ARND2;                                      <<02545>>18704000
                END;                                           <<02693>>18706000
                << If CCG, then report EOF. >>                 <<02693>>18708000
              END;                                             <<02545>>18712000
            END;     << handle EOF on labeled tape >>          <<00901>>18714000
         ASMB(XCH,ZROB);                                                18716000
         TOS := IOSTAT(*);    << convert error nr. >>                   18718000
         IF S0 = BOT AND ACB'DTYPE = MTAPE THEN                <<02545>>18720000
            SET'LPDT'BOT(ACB'DADDR,1);                         <<02545>>18722000
         ASMB(TEST);          << 0 = EOF. >>                            18724000
         IF = THEN GO E2;   << Report CCG on TM >>             <<02693>>18726000
         GO NFG;            << Some other error. Gripe >>      <<02693>>18730000
         END;     << error >>                                           18732000
ARND2:                                                         <<00901>>18734000
      DDEL;      << ATTACHIO results >>                        <<02545>>18736000
      END;        << subroutine TAPEFUNC >>                             18738000
$  IF X0 = ON                                                           18740000
   IF MONCALLABLE THEN                                                  18742000
      BEGIN      << Monitoring >>                                       18744000
      FTITLE("FSPA","CE  ",0D,0D);                                      18746000
      DEBUG                                                             18748000
      END;                                                              18750000
$  IF                                                                   18752000
                                                                        18754000
   <<* * * Build an ACB  * * *>>                                        18756000
                                                                        18758000
   ERRORON;                                                             18760000
   CRIT := SETCRITICAL;                                                 18762000
   GET'ACB'Q'LOC;                                              <<04591>>18764000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);    << get ACB >>            <<04591>>18766000
   IF < THEN                                                            18768000
      BEGIN         << Invalid file nr. >>                              18770000
      TOS := CCL;                                                       18772000
      TOS := INVFN;                                                     18774000
      GO EXIT                                                           18776000
      END;                                                              18778000
   IF > THEN                                                            18780000
      BEGIN         << File is $NULL. Report EOF  >>                    18782000
      TOS := CCG;                                                       18784000
      TOS := 0;    << no error >>                                       18786000
      GO EXIT                                                           18788000
      END;                                                              18790000
                                                                        18792000
   <<* * * Space file * * *>>                                           18794000
                                                                        18796000
   CASE * FTYPE OF                                                      18798000
   BEGIN                                                                18800000
                                                                        18802000
   BEGIN     << conventional file >>                                    18804000
   IF IOQX <> 0 THEN                                                    18806000
      BEGIN         << No-Wait I/O pending >>                           18808000
      TOS := IOPENDING;                                                 18810000
      GO NFG                                                            18812000
      END;                                                              18814000
   IF ACB'SPOOLED THEN                                                  18816000
      BEGIN        << Can't space spoofles. >>                          18818000
      TOS := SPOOLILLOP;                                                18820000
      GO NFG;                                                           18822000
      END;                                                              18824000
   IF ACB'VARIABLE OR ACBAPPEND THEN                                    18826000
      BEGIN     << Illegal access. >>                                   18828000
      TOS := ACCVIOL;                                                   18830000
      GO NFG                                                            18832000
      END;                                                              18834000
   ACB'ERROR := 0;                                                      18836000
   IF ACB'ACCCL = DIRACC THEN                                           18838000
      BEGIN      << Disk >>                                             18840000
      IF ACBCIRFILE AND NOT ACBREAD THEN                       <<HM.00>>18842000
         BEGIN                                                 <<HM.00>>18844000
         TOS:=ACCVIOL;                                         <<HM.00>>18846000
         GO NFG;                                               <<HM.00>>18848000
         END;                                                  <<HM.00>>18850000
      IF ACB'INHIBITBUF THEN  << unbuffered access? >>                  18852000
         NEWPOS := DOUBLE(DSPL)*DOUBLE(ACB'BLKFACT)            <<04561>>18854000
      ELSE  IF NOT ACB'RIO  THEN       << Buffered access >>   <<04450>>18856000
         FQUIESCE'IO(0);       << Complete any pending I/O >>           18858000
      NEWPOS := ACB'FPTR+NEWPOS;  << New pointer value.     >> <<04561>>18860000
      IF < THEN NEWPOS := 0D;     << before beginning of file?>>        18862000
      IF ACB'FCB=0 AND NEWPOS >= DISCSIZE(ACB'DADDR) OR                 18864000
         ACB'FCB <> 0 AND NEWPOS >= GETFCB'INFO(ACB'FCB,XFLIM) THEN     18866000
         BEGIN              << Beyond file limit. >>                    18868000
E2:      TOS := CCG;        << EOF condition code >>                    18870000
         TOS := 0;          << no error >>                              18872000
         GO UNLK                                                        18874000
         END;                                                           18876000
      TOS := NEWPOS;                                                    18878000
      ACB'FPTR := DS1;       << update >>                               18880000
      X := ACB'BLKFACT;                                                 18882000
      DIVD'DEL;                                                         18884000
      ACBHIBLK := TOS-1D;  << update high block nr. >>                  18886000
                                                                        18888000
      IF ACB'RIO AND NOT ACB'INHIBITBUF THEN  << get activity  <<02054>>18890000
         IOMOVE(%50,DUM,0);                                             18892000
                                                                        18894000
      <<* * * Measurement data on FSPACE * * *>>                        18896000
                                                                        18898000
$  IF X3 = ON                                                           18900000
      IF MEAS'TAPE'ON THEN BEGIN                                        18902000
      MMSTAT(EFSPACE,FILENUM,DSPL,0)                                    18904000
      END; << OF MEAS'TAPE'ON>>                                         18906000
$  IF                                                                   18908000
      END      << disk >>                                               18910000
                                                                        18912000
   ELSE IF ACB'ACCCL = SERIALIO OR ACB'DTYPE = SDISC THEN               18914000
      BEGIN               << Magnetic tape or serial disk >>            18916000
      TOS := DSPL;                                                      18918000
      IF > THEN                                                         18920000
         BEGIN                                                 <<02545>>18922000
         TOS := 11;    << Forward space: FSR >>                <<02545>>18924000
         END                                                   <<02545>>18926000
      ELSE                                                              18928000
         BEGIN     << space backward >>                                 18930000
         TOS := -TOS;  << make displacement positive >>                 18932000
         TOS := 12    << BSR code >>                                    18934000
         END;                                                           18936000
      I := TOS;      << FSR/BSR code >>                                 18938000
      DSPL := TOS;   << positive displacement >>                        18940000
                                                               <<04591>>18942000
      <<****************************************************>> <<04591>>18944000
      << Before FSPACING, we must back space over all pre-  >> <<04591>>18946000
      << reads based on the value of ACB'TAPEDISP, obtained >> <<04591>>18948000
      << from FQUIESCE'IO, which counts them. In this way,  >> <<04591>>18950000
      << the head points to the correct current block.      >> <<04591>>18952000
      <<****************************************************>> <<04591>>18954000
                                                               <<04591>>18956000
      IF NOT ACB'INHIBITBUF THEN                                        18958000
         BEGIN        << Buffered access >>                             18960000
         TOS := FQUIESCE'IO(FALSE); << TOS MUST MUST be used>> <<04591>>18962000
         ACB'TAPEDISP := TOS; << so the ACB is at Q-62!!!!! >> <<04591>>18964000
         IF ACB'NEWEOF THEN                                    <<04591>>18966000
            BEGIN                                              <<04591>>18968000
            ACB'TAPEDISP := 0;<< No pre-reads were performed>> <<04591>>18970000
            END                                                <<04591>>18972000
         ELSE                                                  <<04591>>18974000
            WHILE ACB'TAPEDISP > 0 DO                          <<04591>>18976000
               BEGIN                                           <<04591>>18978000
               ATTIO(12);    << Back Space Record >>           <<04591>>18980000
               ACB'TAPEDISP := ACB'TAPEDISP - 1;               <<04591>>18982000
               END;                                            <<04591>>18984000
         END;      << buffered access >>                                18986000
      IF ACB'NEWEOF AND LI THEN                                <<02545>>18988000
         BEGIN     << Forward space after Write loses. >>      <<02545>>18990000
         TOS := INVOP;                                         <<02545>>18992000
         GO NFG;                                               <<02545>>18994000
         END;                                                  <<02545>>18996000
      IF ACB'DTYPE = MTAPE AND LI AND DSPL <> 0 THEN           <<02545>>18998000
         SET'LPDT'BOT(ACB'DADDR,0);                            <<02545>>19000000
      IF ACB'LABELLED THEN                                     <<02545>>19002000
         BEGIN                                                 <<02545>>19004000
         TOS := CHECKUL(FILENUM,6,ACB'NEWEOF&LSL(1)            <<02545>>19006000
            +(LI LAND 1));                                     <<02545>>19008000
         IF < THEN GO NFG;    << error >>                      <<02545>>19010000
         DEL;                                                  <<02545>>19012000
         END                                                   <<02545>>19014000
      ELSE IF ACB'NEWEOF THEN                                  <<02545>>19016000
         BEGIN    << Backspace after write: TM needed. >>               19018000
         ATTIO(6);      << WTM >>                              <<02693>>19022000
         ATTIO(12);     << BSR over it >>                      <<02693>>19024000
         END;                                                  <<02545>>19026000
      ACB'NEWEOF := 0;      << clear EOF Needed flag >>        <<02545>>19028000
      TOS := DSPL;                                                      19032000
      WHILE <> DO                                                       19034000
         BEGIN      << Space tape per request >>                        19036000
         TAPEFUNC(I);     << FSR or BSR >>                     <<02693>>19038000
         TOS := TOS-1                                                   19040000
         END;                                                           19042000
      ACB'FPTR := 0D;                                                   19044000
      ACBHIBLK := -1D                                                   19046000
      END      << mag tape or serial disk >>                            19048000
   ELSE                                                                 19050000
      BEGIN       << Other devices lose. >>                             19052000
      TOS := DEVVIOL;                                                   19054000
NFG:  TOS := CCL;                                                       19056000
      ACB'ERROR := S1;                                                  19058000
      ASMB(XCH);                                               <<HM.00>>19060000
      GO UNLK;                                                          19062000
      END;                                                              19064000
   TOS := CCE;    << OK condition code >>                               19066000
   TOS := 0;      << no error >>                                        19068000
                                                                        19070000
UNLK:                                                                   19072000
   UNLOC'ACB(ACBMQ,0);     << release ACB >>                   <<04591>>19074000
   END;       << conventional file >>                                   19076000
                                                                        19078000
   BEGIN    << Remote file >>                                           19080000
   SETRFAPTR;                                                  <<DS.00>>19082000
   RFALEN := 5;                                                <<DS.00>>19084000
   TOS := "RFA ";                                              <<DS.00>>19086000
   TOS := 11;                                                  <<DS.00>>19088000
   TOS := RFAFILE;                                             <<DS.00>>19090000
   TOS := DSPL;                                                <<DS.00>>19092000
   MWCNOBUF;                                                   <<DS.00>>19094000
   IF <> THEN                                                  <<DS.00>>19096000
      BEGIN                                                    <<DS.00>>19098000
      TOS := CCL;                                              <<DS.00>>19100000
      TOS := 0;                                                <<DS.00>>19102000
      TOS := RFALINE;                                          <<DS.00>>19104000
      TOS := DSCHKPLABEL;                                      <<DS.00>>19106000
      ASMB(PCAL 0);                                            <<DS.00>>19108000
$  IF X1 = ON                                                           19110000
      IF <> THEN FTROUBLE(486);                                         19112000
$  IF                                                                   19114000
      GO EXIT;                                                 <<DS.00>>19116000
      END;                                                     <<DS.00>>19118000
   DELAPPENDAGE;                                               <<DS.00>>19120000
   TOS := TOS.CC;     << return condition code >>              <<DS.00>>19122000
   TOS := 0;                                                   <<DS.00>>19124000
   END;    << remote file >>                                            19126000
                                                                        19128000
      << dummy 2 >>;                                                    19130000
      << dummy 3 >>;                                                    19132000
      << dummy 4 >>;                                                    19134000
      << dummy 5 >>;                                                    19136000
   BEGIN    << KSAM file >>                                             19138000
   KSPACE(FILENUM,DSPL);                                       <<KS.00>>19140000
   PUSH(STATUS);                                               <<KS.00>>19142000
   TOS := TOS.CC;                                              <<KS.00>>19144000
   TOS := 0;    << Show no error number >>                     <<KS.00>>19146000
   END;       << KSAM file >>                                  <<KS.00>>19148000
   <<DUMMY 7>>;                                                <<HM.00>>19150000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>19152000
   TOS:=ACCVIOL;                                               <<HM.00>>19154000
   GO NFG;                                                     <<HM.00>>19156000
   END;                                                        <<HM.00>>19158000
   END;      << FTYPE case >>                                           19160000
                                                                        19162000
EXIT:                                                                   19164000
   ERR := TOS;       << error number >>                                 19166000
   CONDCODE := TOS;  << condition code to report >>                     19168000
   RESETCRITICAL(CRIT);                                                 19170000
   ERROREXIT(2,ERR,0)                                                   19172000
   END;        << procedure FSPACE >>                                   19174000
$PAGE " FPOINT "                                                        19176000
$CONTROL SEGMENT = FILESYS2   << FPOINT >>                              19178000
PROCEDURE FPOINT(FILENUM,RECNUM);                                       19180000
VALUE FILENUM,RECNUM;                                                   19182000
INTEGER FILENUM;                                                        19184000
DOUBLE RECNUM;                                                          19186000
OPTION PRIVILEGED;                                                      19188000
   BEGIN                                                                19190000
   INTEGER CRIT;       << for SETCRITICAL >>                            19192000
                                                                        19194000
   << Remote file access (RFA) variables: >>                            19196000
                                                                        19198000
   INTEGER POINTER RFAPTR;    << appendage pointer >>          <<DS.00>>19200000
   INTEGER RFALEN;            << appendage length >>           <<DS.00>>19202000
                                                                        19204000
<< Following LOC'ACB params must be last and in order: >>               19206000
   INTEGER ACBMQ;                                              <<04591>>19208000
   INTEGER AFTE;      << AFT entry word 0 >>                            19210000
   INTEGER PACBV;                                                       19212000
   INTEGER LACBV;                                                       19214000
   INTEGER IOQX;                                                        19216000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q + ACBMQ >>     <<04591>>19218000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        19220000
   BUILD'ACB;                                                           19222000
   LOGICAL DSTX;     << User's DST nr. >>                               19224000
                                                                        19226000
$  IF X0 = ON                                                           19228000
   IF MONCALLABLE THEN                                                  19230000
      BEGIN       << Monitoring >>                                      19232000
      FTITLE("FPOI","NT  ",0D,0D);                                      19234000
      DEBUG                                                             19236000
      END;                                                              19238000
$  IF                                                                   19240000
                                                                        19242000
   ERRORON;                                                             19244000
   CRIT := SETCRITICAL;                                                 19246000
   GET'ACB'Q'LOC;                                              <<04591>>19248000
                                                               <<04591>>19250000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);    << get ACB >>            <<04591>>19252000
   IF < THEN                                                            19254000
      BEGIN       << Invalid file nr. >>                                19256000
      TOS := INVFN;                                                     19258000
      TOS := CCL;                                                       19260000
      GO EXIT                                                           19262000
      END;                                                              19264000
   IF > THEN                                                            19266000
      BEGIN        << File is $NULL >>                                  19268000
      TOS := 0;    << report No Error >>                                19270000
      TOS := CCE;                                                       19272000
      GO EXIT                                                           19274000
      END;                                                              19276000
   CASE * FTYPE OF                                                      19278000
   BEGIN                                                                19280000
                                                                        19282000
   BEGIN      << Conventional file >>                                   19284000
   IF IOQX <> 0 THEN                                                    19286000
      BEGIN        << No-wait I/O pending. >>                           19288000
      TOS := IOPENDING;                                                 19290000
      GO NFG                                                            19292000
      END;                                                              19294000
   IF ACB'ACCCL <> DIRACC THEN                                          19296000
      BEGIN          << Not disk. Boo! >>                               19298000
      TOS := DEVVIOL;                                                   19300000
      GO NFG                                                            19302000
      END;                                                              19304000
   IF ACB'VARIABLE OR ACBAPPEND                                <<HM.00>>19306000
      OR ACBCIRFILE AND NOT ACBREAD THEN                       <<HM.00>>19308000
      BEGIN       << Illegal access. >>                                 19310000
      TOS := ACCVIOL;                                                   19312000
NFG:  ACB'ERROR := S0;  << save error nr. in ACB >>                     19314000
      TOS := CCL;     << Report error condition >>                      19316000
      GO UNLK;                                                          19318000
      END;                                                              19320000
   IF ACB'INHIBITBUF THEN                                               19322000
      BEGIN        << NOBUF access >>                                   19324000
      TOS := RECNUM;      << Block number! >>                           19326000
      X := ACB'BLKFACT;                                                 19328000
      MPYD;         << Get record number >>                             19330000
      RECNUM := TOS                                                     19332000
      END                                                               19334000
   ELSE  IF NOT ACB'RIO  THEN      << Buffered access >>       <<04450>>19336000
      FQUIESCE'IO(0);  << complete any pending I/O >>                   19338000
   IF RECNUM < 0D THEN                                         <<02068>>19340000
      BEGIN                                                    <<02068>>19342000
      TOS := BADRECNO;                                         <<02068>>19344000
      ACB'ERROR := S0;                                         <<02068>>19346000
      TOS := CCL;                                              <<02068>>19348000
      GO UNLK;                                                 <<02068>>19350000
      END                                                      <<02068>>19352000
   ELSE IF                                                     <<02068>>19354000
      ACB'FCB = 0 AND RECNUM >= DISCSIZE(ACB'DADDR) OR         <<01672>>19356000
      ACB'FCB<>0 AND RECNUM >= GETFCB'INFO(ACB'FCB,XFLIM) THEN <<01672>>19358000
      BEGIN       << Out of bounds; report EOF. >>                      19360000
      TOS := EOF;                                                       19362000
      ACB'ERROR := S0;                                                  19364000
      TOS := CCG;                                                       19366000
      GO UNLK;                                                          19368000
      END;                                                              19370000
   TOS := RECNUM;                                                       19372000
   ACB'FPTR := DS1;     << Set record pointer >>                        19374000
   X := ACB'BLKFACT;                                                    19376000
   DIVD'DEL;                                                            19378000
   ACBHIBLK := TOS-1D;  << Set block nr. for pre-reads >>               19380000
   IF ACB'RIO AND NOT ACB'INHIBITBUF THEN  << get activity >>  <<02054>>19382000
      IOMOVE(%50,DUM,0);                                                19384000
                                                                        19386000
   <<* * * Measurement data on FPOINT * * *>>                           19388000
                                                                        19390000
$  IF X3 = ON                                                           19392000
   IF MEAS'TAPE'ON THEN BEGIN                                           19394000
   TOS := EFPOINT;     << event nr. >>                                  19396000
   TOS := FILENUM;                                                      19398000
   TOS := RECNUM;                                                       19400000
   MMSTAT(*,*,*,*);                                                     19402000
   END; << OF MEAS'TAPE'ON>>                                            19404000
$  IF                                                                   19406000
                                                                        19408000
   TOS := 0;     << No error >>                                         19410000
   TOS := CCE;  << condition code to report >>                          19412000
UNLK:                                                                   19414000
   UNLOC'ACB(ACBMQ,0);     << release ACB >>                   <<04591>>19416000
   END;      << conventional file >>                                    19418000
                                                                        19420000
   BEGIN    << remote file >>                                           19422000
   SETRFAPTR;                                                  <<DS.00>>19424000
   RFALEN := 6;                                                <<DS.00>>19426000
   TOS := "RFA ";                                              <<DS.00>>19428000
   TOS := 12;                                                  <<DS.00>>19430000
   TOS := RFAFILE;                                             <<DS.00>>19432000
   TOS := RECNUM;                                              <<DS.00>>19434000
   MWCNOBUF;                                                   <<DS.00>>19436000
   CHECKXFER;                                                  <<DS.00>>19438000
   DELAPPENDAGE;                                               <<DS.00>>19440000
   PREPRETURN;                                                 <<DS.00>>19442000
   END;     << remote file >>                                           19444000
      << dummy 2 >>;                                                    19446000
      << dummy 3 >>;                                                    19448000
      << dummy 4 >>;                                                    19450000
      << dummy 5 >>;                                                    19452000
   BEGIN         << KSAM file >>                                        19454000
   KPOINT(FILENUM,RECNUM);                                     <<KS.00>>19456000
   PUSH(STATUS);                                               <<KS.00>>19458000
   TOS := TOS.CC;    << return condition code >>               <<KS.00>>19460000
   ASMB(ZERO,XCH);                                             <<KS.00>>19462000
   END;    << KSAM file >>                                     <<KS.00>>19464000
   <<DUMMY 7>>;                                                <<HM.00>>19466000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>19468000
   TOS:=ACCVIOL;                                               <<HM.00>>19470000
   GO NFG;                                                     <<HM.00>>19472000
   END;                                                        <<HM.00>>19474000
   END;      << FTYPE case >>                                           19476000
                                                                        19478000
EXIT:                                                                   19480000
   CONDCODE := TOS;  << report condition code >>                        19482000
   RESETCRITICAL(CRIT);                                                 19484000
   ERROREXIT(3,S0,0)                                                    19486000
   END;    << procedure FPOINT >>                                       19488000
$PAGE " FCONTROL "                                                      19490000
$CONTROL SEGMENT = FILESYS2   << FCONTROL >>                            19492000
PROCEDURE FCONTROL(FILENUM,CODE,PARAM);                                 19494000
   << Performs control operations on the specified file.                19496000
                                                                        19498000
     Input variables:                                                   19500000
         FILENUM - file number                                          19502000
         CODE - Control code                                            19504000
            0 - general device control                                  19506000
            1 - line control                                            19508000
            2 - complete (quiesce) I/O                                  19510000
            3 - read hardware status word                               19512000
            4 - set terminal time-out interval                          19514000
            5 - rewind file                                             19516000
            6 - write EOF                                               19518000
            7 - space forward to tape mark                              19520000
            8 - space backward to tape mark                             19522000
            9 - rewind and unload tape                                  19524000
           10 - change terminal input speed                             19526000
           11 - change terminal output speed                            19528000
           12 - turn terminal echo on                                   19530000
           13 - turn terminal echo off                                  19532000
           14 - disable Break                                           19534000
           15 - enable Break                                            19536000
           16 - disable subsystem Break (Control-Y)                     19538000
           17 - enable subsystem Break (Control-Y)                      19540000
           18 - disable terminal tape mode                              19542000
           19 - enable terminal tape mode                               19544000
           20 - disable terminal input timer                            19546000
           21 - enable terminal input timer                             19548000
           22 - read terminal input timer                               19550000
           23 - disable parity checking                                 19552000
           24 - enable parity checking                                  19554000
           25 - set terminal line termination character                 19556000
           26 - disable binary transfers                                19558000
           27 - enable binary transfers                                 19560000
           28 - disable user mode block transfers                       19562000
           29 - enable user mode block transfers                        19564000
           30 - disable VIEW handshake mode                             19566000
           31 - enable VIEW handshake mode                              19568000
           32 - disable F1/F2 Escape sequences                          19570000
           33 - enable F1/F2 Escape sequences                           19572000
           34 - disable line deletion echo suppression                  19574000
           35 - enable line deletion echo suppression                   19576000
           36 - set parity                                              19578000
           37 - allocate terminal                                       19580000
           38 - set terminal type                                       19582000
           39 - get terminal type                                       19584000
           40 - get terminal output speed                               19586000
           41 - unedited terminal mode                                  19588000
           42 - MAKRO character write                                   19590000
           43 - abort No-wait I/O                                       19592000
           44 - ENABLE/DISABLE TRACE (MSG FILES)                 HM.00  19594000
           45 - ENABLE/DISABLE EXTENDED WAIT (MSG FILES)         HM.00  19596000
           46 - ENABLE/DISABLE EXTENDED READ (MSG FILES)         HM.00  19598000
           47 - NONDESTRUCTIVE READ (MSG FILES)                  HM.00  19600000
           48 - ARM/DISARM SOFTWARE INTERRUPTS                   HM.XX  19602000
         PARAM - utility parameter defined for following codes only:    19604000
            0 - Transmitted to and received from driver                 19606000
            1 - carriage control code                                   19608000
            4 - time-out interval in seconds                            19610000
           10 - new input speed                                         19612000
           11 - new output speed                                        19614000
           25 - new line termination character                          19616000
           36 - new parity code                                         19618000
           37 - terminal specifications                                 19620000
              (0:11) - speed in CPS                                     19622000
              (11:5) - terminal type code                               19624000
           38 - terminal type code                                      19626000
           41 - control characters                                      19628000
              (0:8) - ATTENTION character                               19630000
              (8:8) - End of Record character                           19632000
           42 - two characters                                          19634000
                                                                        19636000
     Output variables:                                                  19638000
         PARAM - Utility parameter returned for following codes only:   19640000
            0 - Driver status                                           19642000
            1 - Previous mode control (0=Post-, 1=pre-spacing)          19644000
            3 - Hardware status word                                    19646000
           10 - Previous terminal input speed                           19648000
           11 - Previous terminal output speed                          19650000
        12,13 - Previous echo state (0=ON,1=OFF)                        19652000
           22 - Terminal input time in hundredths of seconds            19654000
           36 - Old parity code                                         19656000
           39 - Terminal type code                                      19658000
           40 - Terminal output speed                                   19660000
                                                                        19662000
     Condition code:                                                    19664000
         CCE - OK                                                       19666000
         CCL - Error                                                    19668000
                                                                        19670000
   DB may be at any data segment when this procedure is called.    >>   19672000
                                                                        19674000
VALUE FILENUM,CODE;                                                     19676000
INTEGER FILENUM,CODE,PARAM;                                             19678000
OPTION PRIVILEGED;                                                      19680000
   BEGIN                                                                19682000
   ENTRY  kfcontrol'ksam;                                      <<02089>>19684000
   EQUATE UBND = -7; << Q rel upper bound for bounds check>>   <<03059>>19686000
   DEFINE ACTDEF =                                                      19688000
      IF NOT (ACB'FOPTIONS.(10:3) = 0) THEN GO E9#;                     19690000
                                                                        19692000
   INTEGER ARRAY FCB(0:SIZEBFCB+2-1) = Q;                               19694000
   DOUBLE ARRAY FCBDBL(*) = FCB;                                        19696000
   INTEGER  ACBMQ,  << Q relative location of ACB.          >> <<04591>>19698000
            FCBMQ;  << Q relative location of FCB.          >> <<04591>>19700000
EQUATE  BKUP = SIZEBFCB+2-XEOF;                                <<04591>>19702000
   INTEGER CRIT;            << for SETCRITICAL >>                       19704000
   INTEGER A;               << for GETSIR >>                            19706000
   LOGICAL DTYPE;           << device type from ACB >>                  19708000
   INTEGER FUNC;            << ATTACHIO function >>                     19710000
   INTEGER CTLA := 0;       << ATTACHIO first parameter >>              19712000
   INTEGER CTLB := 0;       << ATTACHIO second parameter >>             19714000
   LOGICAL FLAG := %11;     << ATTACHIO flag - Blocked with SBUF's >>   19716000
   LOGICAL TOG := FALSE;    << Return parameter to user? >>             19718000
   LOGICAL ksam'ept;  << do a special fcontrol 6 >>            <<02089>>19720000
   INTEGER JUNK;            << utility variable >>                      19722000
   DOUBLE DISKADR;          << file label sector nr. >>                 19724000
   INTEGER POINTER FLAB;     << file label buffer >>                    19726000
   DOUBLE POINTER FLABDBL = FLAB;                                       19728000
   LOGICAL MODE;                                               <<00546>>19730000
   LOGICAL LDEV := 0;                                          <<00546>>19732000
   LOGICAL LDEVIN := 0;                                        <<00546>>19734000
   DOUBLE IO'STATUS;  << Return parm from ATTACHIO.         >> <<04591>>19736000
   INTEGER                                                     <<04591>>19738000
          WAITIO'STATUS = IO'STATUS, << Word 1 of return.   >> <<04591>>19740000
          WAITIO'TLOG   = IO'STATUS+1; << Word 2 of return. >> <<04591>>19742000
                                                                        19744000
                                                                        19746000
   << Remote file access (RFA) variables: >>                            19748000
                                                                        19750000
   INTEGER POINTER RFAPTR;    << appendage pointer >>                   19752000
   INTEGER RFALEN;            << appendage length >>                    19754000
                                                               <<HM.00>>19756000
   << MESSAGE FILE DECLARATIONS >>                             <<HM.00>>19758000
   EQUATE LOWMSGVAL = 45;                                      <<HM.00>>19760000
   EQUATE HIMSGVAL  = 48;                                      <<03038>>19762000
                                                                        19764000
<< Following LOC'ACB params must be last and in order: >>               19766000
   INTEGER AFTE;       << AFT entry word 0 >>                           19768000
   INTEGER PACBV;                                                       19770000
   INTEGER LACBV;                                                       19772000
   INTEGER IOQX;                                                        19774000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>                19776000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        19778000
   BUILD'ACB;                                                           19780000
   LOGICAL ACB'CTL      = ACB+11;                                       19782000
   DOUBLE ACB'RTFRCT    = ACB+20;                                       19784000
                                                                        19786000
   LOGICAL DSTX;      << User's DB setting >>                           19788000
<< End of LOC'ACB params >>                                             19790000
                                                                        19792000
   INTRINSIC  WHO;                                             <<00546>>19794000
                                                                        19796000
   SUBROUTINE LABELIO (RW);                                             19798000
      << Reads or writes the file label into the stack buffer.          19800000
                                                                        19802000
        Input variables:                                                19804000
           RW - I/O mode                                                19806000
              0 - Read                                                  19808000
              1 - Write                                                 19810000
                                                                        19812000
      DB must be at the stack when this subroutine is called.   >>      19814000
                                                                        19816000
   VALUE RW;                                                            19818000
   INTEGER RW;                                                          19820000
      BEGIN                                                             19822000
      X := FLABIO(DTYPE,DISKADR,RW,FLAB);  <<R/W label>>                19824000
      IF <> THEN                                                        19826000
         BEGIN       << Error. >>                                       19828000
         FLABIOERR(X,FILENUM);  << handle error >>                      19830000
         RELSIR(FISIR,A);       << release File SIR >>                  19832000
         EXCHANGEDB(JUNK);     << reset DB to original >>               19834000
         UNLOCK'CB(0,ACB'FCB.DSTN,ACB'FCB VTA);                         19836000
         TOS := LBLIOERR;                                               19838000
         GO ERR                                                         19840000
         END                                                            19842000
      END;      << subroutine LABELIO >>                                19844000
                                                                        19846000
   SUBROUTINE REWINDACB;                                                19848000
   << This subroutine "rewinds" the ACB. >>                             19850000
      BEGIN                                                             19852000
      ACB'FPTR := 0D;    << Reset file pointer >>                       19854000
      ACBHIBLK := -1D;   << Reset highest block nr. >>                  19856000
      IF ACB'VARIABLE THEN                                              19858000
         BEGIN                                                          19860000
         ACBBUFUSED := 0;                                               19862000
         ACBBLK := 0D   << Reset var. block pointer >>                  19864000
         END;                                                           19866000
      ACB'NEWEOF := 0;                                         <<04591>>19868000
      ACB'EOF := 0;       << Note: sets CC per prior state. >>          19870000
      END;                                                              19872000
                                                                        19874000
   DOUBLE SUBROUTINE ATTIO(FUNC);                                       19876000
VALUE FUNC; INTEGER FUNC;                                               19878000
   << Shortcut to call ATTACHIO. >>                                     19880000
                                                                        19882000
      ATTIO := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,0,4,BFLAGS);    <<02693>>19884000
                                                                        19886000
   SUBROUTINE TM;                                                       19888000
   << If the New EOF Needed flag is set in the ACB, a tape mark         19890000
      is written and the tape backspaced over it.    >>                 19892000
                                                                        19894000
      BEGIN                                                             19896000
      IF ACB'NEWEOF THEN                                                19898000
         BEGIN        << Tape mark needed. >>                           19900000
         TOS := ATTIO(6);      << WTM >>                                19902000
         ASMB(DEL,DUP);        << replicate returned status >>          19904000
         IF TOS.(8:8) <> 1 THEN                                         19906000
            BEGIN              << ATTACHIO reports error. >>            19908000
            ASMB(ZERO,XCH);    << for result of IOSTAT >>               19910000
            TOS := IOSTAT(*);   << convert error nr. >>                 19912000
            ASMB(TEST);        << zero if EOF >>                        19914000
            IF <> AND S0 <> EOT AND S0 <> TAPERREC THEN GO ERR <<02712>>19916000
            END;                                                        19918000
         DEL;                                                           19920000
         ACB'NEWEOF := 0;    << Clear EOF Needed flag >>                19922000
   << Backspace File over new tapemark, wait for completion >>          19924000
         TOS := ATTIO(8);     <<BF>>                                    19926000
         ASMB(DEL,DUP);                                                 19928000
         IF TOS.(8:8) <> 1 THEN                                         19930000
            BEGIN            << ATTACHIO reports error. >>              19932000
            ASMB(ZERO,XCH);    << for result of IOSTAT >>               19934000
            TOS := IOSTAT(*);   << convert error nr. >>                 19936000
            IF S0 <> EOF AND S0 <> TAPERREC THEN GO ERR;       <<03532>>19938000
            END;                                                        19940000
         DEL                                                            19942000
         END                                                            19944000
      END;     << subroutine TM >>                                      19946000
                                                                        19948000
   << special entry point to bypass extent   >>                <<02089>>19950000
   << initialization on an fcontrol 6 ONLY!  >>                <<02089>>19952000
   << For ksamutil keyinfo;recover           >>                <<02089>>19954000
   IF (ksam'ept:=false) THEN                                   <<02089>>19956000
      BEGIN                                                    <<02089>>19958000
kfcontrol'ksam:   ksam'ept:=true;                              <<02089>>19960000
      END;                                                     <<02089>>19962000
                                                               <<02089>>19964000
$  IF X0 = ON                                                           19966000
   IF MONCALLABLE THEN                                                  19968000
      BEGIN        << monitoring >>                                     19970000
      FTITLE("FCON","TROL",0D,0D);                                      19972000
      DEBUG                                                             19974000
      END;                                                              19976000
$  IF                                                                   19978000
                                                                        19980000
   ERRORON;                                                             19982000
   CRIT := SETCRITICAL;                                                 19984000
      BEGIN      << Parameter out of bounds. >>                         19988000
      TOS := BNDVIOL;                                                   19990000
      GO ERROR                                                          19992000
      END;                                                              19994000
   IF NOT (0 <= CODE <= HIMSGVAL) THEN  <<INVALID CODE?>>      <<HM.00>>19996000
      BEGIN        << Invalid CODE. >>                                  19998000
      TOS := ILLPARM;                                                   20000000
      GO ERROR                                                          20002000
      END;                                                              20004000
   GET'ACB'Q'LOC;                                              <<04591>>20006000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);    << get ACB >>                     20008000
   IF < THEN                                                            20010000
      BEGIN       << invalid file nr. >>                                20012000
      TOS := INVFN;                                                     20014000
ERROR:                                                                  20016000
      CTLA := TOS;     << Error nr. >>                                  20018000
      CONDCODE := CCL;  << error condition code >>                      20020000
      GO GETOUT;                                                        20022000
      END;                                                              20024000
   IF > THEN                                                            20026000
      BEGIN         << File is $NULL >>                                 20028000
      CONDCODE := CCE;                                                  20030000
      GO GETOUT                                                         20032000
      END;                                                              20034000
   IF NOT FBNDCHK (@PARAM, 1, UBND) THEN                       <<03059>>20036000
      BEGIN   << Parameter out of bounds.                   >> <<02556>>20038000
      TOS := BNDVIOL;                                          <<02556>>20040000
CHECK'FTYPE:                                                   <<02556>>20042000
      IF FTYPE = FS'TYPE OR FTYPE = MSG'TYPE                   <<02556>>20044000
        THEN GO ERR      << Stuff error in ACB.             >> <<02556>>20046000
        ELSE GO ERROR;   << No ACB, just scram.             >> <<02556>>20048000
      END;                                                     <<02556>>20050000
   JUNK := PARAM;   << Must follow call to FBNDCHK.         >> <<02642>>20052000
   IF NOT (0 <= CODE <= HIMSGVAL) THEN                         <<02556>>20054000
      BEGIN   << Invalid code.                              >> <<02556>>20056000
      TOS := ILLPARM;                                          <<02556>>20058000
      GO CHECK'FTYPE;                                          <<02556>>20060000
      END;                                                     <<02556>>20062000
   CASE * FTYPE OF                                                      20064000
   BEGIN                                                                20066000
                                                                        20068000
   BEGIN      << conventional file >>                                   20070000
   IF CODE > 43 THEN  <<INVALID CODE?>>                        <<HM.00>>20072000
      BEGIN                                                    <<HM.00>>20074000
      TOS := ILLPARM;                                          <<HM.00>>20076000
      GO ERR                                                   <<HM.00>>20078000
      END;                                                     <<HM.00>>20080000
   IF IOQX <> 0 AND CODE < 42 THEN                                      20082000
      BEGIN        << No-wait I/O pending. >>                           20084000
      TOS := IOPENDING;                                                 20086000
      GO ERR                                                            20088000
      END;                                                              20090000
   IF ACB'SPOOLED AND NOT (1 <= CODE <= 2) THEN GO E3;                  20092000
   ACB'ERROR := 0;                                                      20094000
   DTYPE := IF ACB'SPOOLED THEN ACBSPTYPE ELSE ACB'DTYPE;               20096000
   X := IF CODE < 10 THEN CODE                                          20098000
        ELSE IF (10 <= CODE <= 42) THEN 10                              20100000
        ELSE 11;                                                        20102000
   CASE * X OF                                                          20104000
      BEGIN                                                             20106000
                                                                        20108000
   <<* * * 0 - General device control * * *>>                           20110000
                                                                        20112000
      BEGIN                                                             20114000
      CTLA := JUNK;    << user's control param. >>                      20116000
      FUNC := 28;      << control function >>                           20118000
      FLAG := 1;       << blocked request >>                            20120000
      TOG := TRUE      << report the result >>                          20122000
      END;                                                              20124000
                                                                        20126000
   <<* * * 1 - Line control * * *>>                                     20128000
                                                                        20130000
      BEGIN                                                             20132000
      IF DTYPE <> LPTR AND DTYPE <> TERMINAL THEN   <<illegal?>>        20134000
         IF ACB'SPOOLED THEN                                            20136000
            BEGIN                                                       20138000
E3:         TOS := SPOOLILLOP;                                          20140000
            GO ERR;                                                     20142000
            END                                                         20144000
         ELSE GO E1;                                                    20146000
      IF JUNK = 1 THEN                                                  20148000
         BEGIN       << Illegal control. >>                             20150000
         TOS := BADCONTROL;                                             20152000
         GO ERR                                                         20154000
         END;                                                           20156000
      IF NOT ACB'INHIBITBUF AND NOT ACB'SPOOLED THEN                    20158000
         FQUIESCE'IO(0);   << Complete physical I/O >>                  20160000
      IF (%400 <= JUNK <= %403) THEN JUNK := JUNK-%300;  <<re-map?>>    20162000
      IF (%100 <= JUNK <= %101) THEN                                    20164000
         BEGIN           << Set pre- or post-spacing. >>                20166000
         TOG := TRUE;     << report old state >>                        20168000
         TOS := 0;        << for old state value >>                     20170000
         ACB'LINECTL := JUNK;  << new state >>                          20172000
         IF <> THEN TOS := TOS+1;                                       20174000
         JUNK := TOS;      << old state >>                              20176000
         GO FSEXIT                                                      20178000
         END;                                                           20180000
      IF (%102 <= JUNK <= %103) THEN                                    20182000
         BEGIN        << Set auto page control >>                       20184000
         ACB'PAGECTL := JUNK;  << new state >>                          20186000
         GO FSEXIT                                                      20188000
         END;                                                           20190000
      IF ACB'SPOOLED THEN                                               20192000
         BEGIN    << Write spoofle record noting change. >>             20194000
         ACB'CTL := JUNK;                                               20196000
         ACB'NEWEOF := 1;                                               20198000
         IOMOVE(2,DUM,0);  << write ctrl rec >>                         20200000
         GO FSEXIT                                                      20202000
         END;                                                           20204000
      CTLA := JUNK;      << control code >>                             20206000
      TOS := ACB'LPCTL;   << line and page control >>                   20208000
      IF DTYPE = TERMINAL THEN                                          20210000
         BEGIN                                                          20212000
         TOS.(10:1) := ACB'TBLOCK;  << disable Block mode >>            20214000
         TOS.(12:1) := ACB'BINARYIO  << 8-bit transfers >>              20216000
         END                                                            20218000
      ELSE      << line printer >>                                      20220000
         TOS.(12:1) := NOT ACB'ASCII;  << ASCII/binary mode >>          20222000
      CTLB := TOS;        << device controls >>                         20224000
      FUNC := 1      << WRITE >>                                        20226000
      END;                                                              20228000
                                                                        20230000
   <<* * * 2 - Complete I/O * * *>>                                     20232000
                                                                        20234000
      BEGIN                                                             20236000
      IF NOT ACB'INHIBITBUF AND NOT ACB'SPOOLED THEN                    20238000
         FQUIESCE'IO(0);   << Complete I/O >>                           20240000
      GO FSEXIT                                                         20242000
      END;                                                              20244000
                                                                        20246000
   <<* * * 3 - Read hardware status word * * *>>                        20248000
                                                                        20250000
      BEGIN                                                             20252000
      JUNK := DEVICESTATUS(ACB'DADDR);  << get hardware status >>       20254000
      IF < THEN GO E1;     << if error >>                               20256000
      TOG := TRUE;        << report returned value >>                   20258000
      GO FSEXIT                                                         20260000
      END;                                                              20262000
                                                                        20264000
   <<* * * 4 - Set time-out interval * * *>>                            20266000
                                                                        20268000
      BEGIN                                                             20270000
      IF DTYPE <> TERMINAL THEN GO E1;  << must be terminal >>          20272000
      FUNC := 5;        << tell driver to set timeout >>                20274000
      CTLA := JUNK       << timeout value >>                            20276000
      END;                                                              20278000
                                                                        20280000
   <<* * * 5 - Rewind file * * *>>                                      20282000
   <<  REWIND should not be allowed if acc=APPEND.  This     >><<02353>>20284000
   <<  change was put in to prevent append-only files from   >><<02353>>20286000
   <<  being 'scratched' if REWIND was followed by WRITE EOF.>><<02353>>20288000
   <<  For multi-reel tape handling, user should use FCONTROL>><<02353>>20290000
   <<  9 (REWIND/UNLOAD).                                    >><<02353>>20292000
                                                                        20294000
      BEGIN                                                             20296000
      IF ACB'ACCCL = DIRACC THEN                                        20298000
         BEGIN          << Disk >>                                      20300000
         IF ACB'APPEND THEN GO E9; << Disallow if ACC=APPEND >><<02353>>20302000
         IF NOT ACB'INHIBITBUF THEN FQUIESCE'IO(0); << complete I/O >>  20304000
         REWINDACB;   << set to beginning of file >>                    20306000
         GO FSEXIT                                                      20308000
         END;                                                           20310000
      IF DTYPE = MTAPE OR DTYPE = SDISC THEN                            20312000
         BEGIN       << tape-like device >>                             20314000
         IF ACB'APPEND THEN GO E9; << Disallow if ACC=APPEND >><<02353>>20316000
         FUNC := 5;    << Rewind >>                                     20318000
DOIT:    FLAG := %13;  <<SYS. BUFFER - NO PCB>>                         20320000
         ACTDEF;      << Barf if $STDIN, etc. >>                        20322000
         IF NOT ACB'INHIBITBUF THEN FQUIESCE'IO(0); << Complete I/O >>  20324000
         IF ACB'ERROR = EOT THEN ACB'ERROR := 0;               <<00483>>20326000
         IF LABEL'DEVICE THEN                                  <<03582>>20328000
            BEGIN        << labeled tape >>                    <<02545>>20330000
            TOS := CHECKUL(FILENUM,5,ACB'NEWEOF);              <<02545>>20334000
            IF < THEN GO ERR;                                  <<02545>>20336000
            DEL;                                               <<02545>>20338000
            REWINDACB;                                         <<02545>>20340000
            ACBBTFRCT := 0D;                                   <<02545>>20342000
            GO FSEXIT;                                         <<02545>>20344000
            END;                                               <<02545>>20346000
         TM;     << write tape mark >>                         <<01156>>20348000
         REWINDACB;                                            <<01156>>20350000
         IF DTYPE = MTAPE THEN SET'LPDT'BOT(ACB'DADDR,1);      <<02545>>20352000
         END      << tapelike device >>                                 20354000
      ELSE                                                              20356000
         GO E1     << Other devices lose. >>                            20358000
      END;                                                              20360000
                                                                        20362000
   <<* * * 6 - Write End of File * * *>>                                20364000
                                                                        20366000
      BEGIN                                                             20368000
      IF ACB'ACCCL = DIRACC THEN                                        20370000
         BEGIN          << Disk >>                                      20372000
         IF DTYPE=FDISC THEN GO E1;                            <<01115>>20374000
         IF NOT (1 <= ACB'ACTYPE <= 6) THEN                     <<MRJE>>20376000
            BEGIN     << No Write access. >>                            20378000
E9:         TOS := ACCVIOL;                                             20380000
            GO ERR                                                      20382000
            END;                                                        20384000
         IF NOT ACB'INHIBITBUF THEN FQUIESCE'IO(0); << empty bufs >>    20386000
          << do not initialize extents for special ept >>      <<02089>>20388000
          IF NOT(ksam'ept) THEN iomove(%11,dum,0);             <<02089>>20390000
         A := GETSIR(FISIR);                                            20392000
                                                                        20394000
      <<* * * Update FCBEOF, and get label address * * *>>              20396000
                                                                        20398000
         GET'FCB'Q'LOC;                                        <<04591>>20400000
         LOCK'CB(0,0,FCBMQ,ACB'FCB.DSTN,ACB'FCB VTA);          <<04591>>20402000
         TOS := SIZEBFCB+2;     << word count >>                        20404000
         MOVE'DS'1;             << FCB + first e-map entry >>           20406000
         X := FCB.(2:14);                                               20408000
         IF BADFCBSIZE THEN FTROUBLE(64);                               20410000
         IF NOT ACB'APPEND THEN  << If APPEND, use cur. EOF >> <<02353>>20412000
         FCBEOF := ACB'FPTR;     << post new EOF >>                     20414000
         TOS := TOS-BKUP;         << back up >>                         20416000
         ASMB(DXCH);                                                    20418000
         TOS := TOS-BKUP;         << back up >>                         20420000
         TOS := 2;                                                      20422000
         MOVE'DS'6;               << update FCBEOF. >>                  20424000
         TOS := 0;                 << for LDEV >>                       20426000
         TOS := FCBLABEL;          << LDEV and sector nr.>>             20428000
         TOS := TOS&TASL(8)&DLSR(8);  << separate LDEV >>               20430000
         DISKADR := TOS;          << file label sector nr. >>           20432000
         DTYPE := TOS;           << file label LDEV >>                  20434000
                                                                        20436000
      <<* * * Update file label * * *>>                                 20438000
                                                                        20440000
         JUNK := EXCHANGEDB(0);        << set DB to stack >>            20442000
         ALLOCFLAB;             << allocate file label buffer >>        20444000
         LABELIO(0);            << Read label >>                        20446000
         FLEOF :=                << update EOF >>              <<02353>>20448000
         IF ACB'APPEND THEN FCBEOF ELSE ACB'FPTR;              <<02353>>20450000
         FLUSERLBL := FCBUSERLBL;    << update user label info >>       20452000
         FLSTART:=FCBSTART;                                    <<HM.00>>20454000
         FLEND:=FCBEND;                                        <<HM.00>>20456000
         FLHDRECS:=FCBHDRECS;                                  <<HM.00>>20458000
         LABELIO(1);            << rewrite label >>                     20460000
         RELSIR(FISIR,A);       << release File SIR >>                  20462000
         EXCHANGEDB(JUNK);      << reset DB to original >>              20464000
         UNLOCK'CB(0,ACB'FCB.DSTN,ACB'FCB VTA);                         20466000
         GO FSEXIT                                                      20468000
         END;                                                           20470000
      IF DTYPE=MTAPE OR DTYPE=SSLC OR DTYPE=SDISC THEN         <<SD.00>>20472000
         BEGIN    << Tape,SSLC, or SDISC device >>             <<SD.00>>20474000
         IF NOT (1 <= ACB'ACTYPE <= 6) THEN GO E9;             <<00900>>20476000
         ACTDEF;       << gripe if $STDIN, $STLIST, etc. >>             20478000
         IF NOT ACB'INHIBITBUF THEN                            <<04591>>20480000
            BEGIN                                              <<04591>>20482000
            TOS := FQUIESCE'IO(FALSE); << TOS MUST MUST be  >> <<04591>>20484000
            ACB'TAPEDISP := TOS; << used so ACB is at Q-62!!>> <<04591>>20486000
                                                               <<04591>>20488000
            <<**********************************************>> <<04591>>20490000
            << Backspace one block for every extra pre-read >> <<04591>>20492000
            << to properly position the tape before we write>> <<04591>>20494000
            << the EOF.  ACB'TAPEDISP is obtained from      >> <<04591>>20496000
            << FQUIESCE'IO by counting the I/O's outstanding>> <<04591>>20498000
            <<**********************************************>> <<04591>>20500000
                                                               <<04591>>20502000
            IF ACB'NEWEOF THEN                                 <<04591>>20504000
               ACB'TAPEDISP := 0  << No pre-reads performed.>> <<04591>>20506000
            ELSE                                               <<04591>>20508000
               WHILE ACB'TAPEDISP > 0 DO                       <<04591>>20510000
                  BEGIN                                        <<04591>>20512000
                  IO'STATUS := ATTIO(12);  << BSR >>           <<04591>>20514000
                  IF WAITIO'STATUS <> 1 THEN                   <<04591>>20516000
                     BEGIN                                     <<04591>>20518000
                     JUNK := IOSTAT(WAITIO'STATUS);            <<04591>>20520000
                     IF JUNK <> EOF AND JUNK <> EOT AND        <<04591>>20522000
                        JUNK <> TAPERREC THEN                  <<04591>>20524000
                        BEGIN                                  <<04591>>20526000
                        TOS := JUNK;  << Report the error.  >> <<04591>>20528000
                        GO ERR;                                <<04591>>20530000
                        END;                                   <<04591>>20532000
                     END;                                      <<04591>>20534000
                  ACB'TAPEDISP := ACB'TAPEDISP - 1;            <<04591>>20536000
                  END;                                         <<04591>>20538000
            END;                                               <<04591>>20540000
         FUNC := 6;  <<WTM>>                                            20542000
         IF LABEL'DEVICE THEN GO FSEXIT;                       <<03582>>20544000
         ACB'FPTR := 0D;                                                20548000
         ACBHIBLK := -1D;                                               20550000
         CTLB.(13:1) := 1; <<Write after EOT is OK>>           <<02682>>20552000
         IF DTYPE = MTAPE THEN                                 <<02652>>20554000
            BEGIN                                              <<02652>>20556000
            TOS := WRITE'DENSITY(ACB'DADDR);                   <<02652>>20558000
            IF S1STAT <> 1 THEN                                <<02652>>20560000
               GO REPORT'ERROR;  << Skip WTM. >>               <<02652>>20562000
            DDEL;   << AOK, delete ATTACHIO return >>          <<02652>>20564000
            END;                                               <<02652>>20566000
         END                                                            20568000
      ELSE    << other device >>                                        20570000
         BEGIN                                                          20572000
E1:      TOS := DEVVIOL;                                                20574000
         GO ERR;                                                        20576000
         END;                                                           20578000
      END;                                                              20580000
                                                                        20582000
   <<* * * 7 - Space forward to tape mark * * *>>                       20584000
                                                                        20586000
      BEGIN                                                             20588000
      IF DTYPE<>MTAPE AND DTYPE<>SDISC THEN GO E1;             <<SD.00>>20590000
      IF ACB'NEWEOF AND ACB'LABELLED THEN                               20592000
         BEGIN    << Illegal after writing labeled tape. >>             20594000
         TOS := ILLPARM;                                                20596000
         GO ERR                                                         20598000
         END;                                                           20600000
      ACTDEF;      << Gripe if $STDIN, $STDLIST, etc. >>                20602000
      IF ACB'NEWEOF THEN                                       <<04591>>20604000
         BEGIN  << Spacing forward after a write is no-no.  >> <<04591>>20606000
         TOS := INVOP;                                         <<04591>>20608000
         GO ERR;                                               <<04591>>20610000
         END;                                                  <<04591>>20612000
      FUNC := 7;  <<FSF>>                                               20614000
<< Exit if tapemark has been encountered on a Pre-read. >>              20616000
      IF NOT ACB'INHIBITBUF AND FQUIESCE'IO(1) < 0 THEN                 20618000
         GO FSEXIT;     << EOF encountered. >>                          20620000
      REWINDACB;                                                        20622000
      IF <> THEN GO FSEXIT;   << EOF encountered. >>                    20624000
      IF DTYPE = MTAPE THEN SET'LPDT'BOT(ACB'DADDR,0);         <<02545>>20626000
      IF LABEL'DEVICE THEN                                     <<03582>>20628000
         BEGIN      << labeled tape >>                                  20630000
         TOS := CHECKUL(FILENUM,7,0);                          <<02545>>20632000
         IF < THEN GO ERR;                                     <<02545>>20634000
         DEL;                                                  <<02545>>20636000
         GO FSEXIT;                                                     20640000
         END;     << labeled tape >>                                    20642000
      END;                                                              20644000
                                                                        20646000
   <<* * * 8 - Space backward to tape mark * * *>>                      20648000
                                                                        20650000
      BEGIN                                                             20652000
      IF DTYPE <> MTAPE AND DTYPE <> SDISC THEN GO E1;         <<SD.00>>20654000
      IF LABEL'DEVICE THEN GO DOIT;                            <<03582>>20656000
      ACTDEF;         << Barf if $STDIN, etc. >>                        20658000
      FUNC := 8;      <<BSF>>                                           20660000
      IF ACB'INHIBITBUF THEN TM ELSE                                    20662000
         BEGIN       << Buffered. Must discard pre-reads. >>            20664000
         TOS := FQUIESCE'IO(FALSE); << TOS MUST MUST be used>> <<04591>>20666000
         ACB'TAPEDISP := TOS; << so the ACB is at Q-62!!!!! >> <<04591>>20668000
         IF ACB'NEWEOF THEN                                    <<04591>>20670000
            BEGIN                                              <<04591>>20672000
            TM;                 << Write tape mark          >> <<04591>>20674000
            ACB'TAPEDISP := 0;  << No pre-reads performed.  >> <<04591>>20676000
            END                                                <<04591>>20678000
         ELSE                                                  <<04591>>20680000
            WHILE ACB'TAPEDISP > 0 DO                          <<04591>>20682000
               BEGIN                                           <<04591>>20684000
               ATTIO(12);      << BSR >>                       <<04591>>20686000
               ACB'TAPEDISP := ACB'TAPEDISP - 1;               <<04591>>20688000
               END;                                            <<04591>>20690000
                                                               <<04591>>20692000
         END;                                                           20694000
      IF ACB'ERROR = EOT THEN ACB'ERROR := 0;                  <<00483>>20696000
      REWINDACB;                                                        20698000
      END;                                                              20700000
                                                                        20702000
   <<* * * 9 - Rewind and unload tape file * * *>>                      20704000
                                                                        20706000
      BEGIN                                                             20708000
      IF DTYPE <> MTAPE AND DTYPE <> SDISC THEN GO E1;         <<SD.00>>20710000
      IF LABEL'DEVICE THEN GO FSEXIT;                          <<03582>>20712000
      FUNC := 9;       << Rewind and Unload >>                          20714000
      GO DOIT;                                                          20716000
      END;                                                              20718000
                                                                        20720000
   <<* * * 10 thru 42 - terminal controls * * *>>                       20722000
                                                                        20724000
      BEGIN                                                             20726000
      IF DTYPE <> TERMINAL THEN GO E1;  << Lose if not terminal. >>     20728000
      IF CODE = 15 THEN   << Enable Break requested? >>        <<00546>>20730000
        BEGIN    << See if Break allowed from this device. >>  <<00546>>20732000
        LDEV := ACB'DADDR;     << Get file LDEV >>             <<00546>>20734000
        EXCHANGEDB(0);          << DB to user stack >>         <<00546>>20736000
        WHO(MODE,,,,,,,LDEVIN);  <<get $STDIN MODE & LDEV>>    <<00546>>20738000
        EXCHANGEDB(DSTX);       << reset DB to original >>     <<00546>>20740000
        IF MODE.(12:2) <> 1 THEN GO E1;  <<Not a session. >>   <<00546>>20742000
        IF LDEVIN <> LDEV THEN GO E1;  <<Device not $STDIN>>   <<00546>>20744000
        END;                                                   <<00546>>20746000
      IF CODE = 25 THEN        << New Stop character? >>                20748000
         ACBSTOPCHAR := JUNK                                            20750000
      ELSE IF (26 <= CODE <= 27) THEN  << Binary transfers? >>          20752000
         ACB'BINARYIO := CODE                                           20754000
      ELSE IF (28 <= CODE <= 29) THEN  << User mode block xfers? >>     20756000
         ACB'TBLOCK := CODE                                             20758000
      ELSE IF (30 <= CODE <= 31) THEN  << VIEW handshake? >>            20760000
         ACB'XMITCRLF := CODE                                  <<01790>>20762000
      ELSE IF (32 <= CODE <= 33) THEN  << F1/F2 escape sequences? >>    20764000
         ACBFKEYS := CODE                                               20766000
      ELSE IF CODE = 42 THEN  << Hard pre-emptive write? >>             20768000
         BEGIN                                                          20770000
         IF NOT PRIVMODE THEN                                           20772000
            BEGIN                                                       20774000
            TOS := ILLCAP;                                              20776000
            GO ERR;                                                     20778000
            END;                                                        20780000
         CTLA := ACB'DADDR;       << Save LDEV >>                       20782000
         TOS := EXCHANGEDB(0);   << Set DB to stack >>                  20784000
         TOS := ATTACHIO(CTLA,0,0,@JUNK,1,-2,%320,0,                    20786000
            BFLAGS+%400);                                               20788000
         ASMB(CAB,ZROB);                                                20790000
         EXCHANGEDB(*);        << Reset to user's DB >>                 20792000
         IF TOS.(8:8) <> 1 THEN GO E1  << ATTACHIO error >>             20794000
         END                                                            20796000
      ELSE      << other terminal control >>                            20798000
         BEGIN                                                          20800000
         TOS := %(2)10010100000000000000000000000011D                   20802000
            &DLSR(CODE-10);                                             20804000
         DELB;                                                          20806000
         IF TOS THEN  <<10,11,36,38 OR 41?>>                            20808000
            CTLA := JUNK     << parameter >>                            20810000
         ELSE IF CODE = 37 THEN  << Allocate terminal? >>               20812000
            BEGIN                                                       20814000
            CTLA := JUNK.(11:5);  << terminal type >>                   20816000
            CTLB := JUNK.(0:11)   << terminal speed >>                  20818000
            END;                                                        20820000
         TOS := ATTACHIO(ACB'DADDR,0,0,0,                               20822000
            IF (26 <= CODE <= 35) THEN CODE-8 ELSE CODE-4,              20824000
            0,CTLA,CTLB,BFLAGS);                                        20826000
         JUNK := TOS;      << Old value, if any >>                      20828000
         IF TOS.(8:8) <> 1 THEN GO E1;  << Error. >>                    20830000
         TOS := %(2)1100100000000000001000000001111D&DLSR(CODE-10);     20832000
         DELB;                                                          20834000
         TOG := TOS    << set Return Value flag >>                      20836000
         END;                                                           20838000
      GO FSEXIT                                                         20840000
      END;                                                              20842000
                                                                        20844000
   <<* * * 43 - Abort NO-WAIT I/O * * *>>                               20846000
                                                                        20848000
      BEGIN                                                             20850000
      PUSH(Q, DL);                                                      20852000
      ASMB(XCH, SUB);     << TOS := DL-Q >>                             20854000
      X := TOS-(ACBFNUM+1)*AFTENTRY;  << X := @AFT0(N) >>               20856000
      TOS := AQPL3(X);    << get IOQX from AFT entry >>                 20858000
      AQPL3(X) := 0;      << clear IOQX >>                              20860000
      ASMB(TEST);         << set CC on IOQX >>                          20862000
      IF = THEN                                                         20864000
         BEGIN        << No I/O pending. >>                             20866000
         TOS := NOIOPENDING2;                                           20868000
         GO ERR                                                         20870000
         END;                                                           20872000
      ABORTIOX(*);     << Abort NO-WAIT I/O >>                          20874000
      GO FSEXIT                                                         20876000
      END                                                               20878000
                                                                        20880000
      END;                                                              20882000
                                                                        20884000
<<* * * Perform I/O operation * * *>>                                   20886000
                                                                        20888000
   TOS := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,CTLA,CTLB,                    20890000
      UFLAGS+FLAG);                                                     20892000
   IF FLAG.(13:3) = 1 THEN                                              20894000
      BEGIN         << Blocked request. Examine status >>               20896000
REPORT'ERROR:                                                  <<02652>>20898000
      JUNK := TOS;    << save returned TLOG >>                          20900000
      ACB'STATUS := S0;  << save logical I/O status >>                  20902000
      IF TOS.(8:8) <> 1 THEN                                            20904000
         BEGIN         << ATTACHIO reports error. >>                    20906000
         TOS := IOSTAT(ACB'STATUS);  << convert error nr. >>            20908000
         IF S0 = BOT AND DTYPE = MTAPE THEN                    <<02545>>20910000
            SET'LPDT'BOT(ACB'DADDR,1);                         <<02545>>20912000
         IF S0 <> 0 AND S0 <> TAPERREC THEN                    <<02712>>20916000
            <<Error other than EOF or tape retry>>             <<02712>>20918000
            BEGIN         << Other than EOF. >>                         20920000
  ERR:      CTLA := ACB'ERROR := TOS;  << error nr. >>         <<02712>>20922000
            CONDCODE := CCL;         << error condition code >><<02712>>20924000
            GO UNLK;                                           <<02712>>20926000
            END;                                               <<02712>>20928000
         END;               << error >>                        <<02712>>20930000
      END;                << examine status >>                          20932000
FSEXIT:                                                                 20934000
   CTLA := 0;                                                           20936000
   CONDCODE := CCE;                                                     20938000
                                                                        20940000
UNLK:                                                                   20942000
   UNLOC'ACB(ACBMQ,0);    << release ACB >>                             20944000
   END;      << conventional file >>                                    20946000
                                                                        20948000
   BEGIN     << Remote file >>                                          20950000
   SETRFAPTR;                                                  <<DS.00>>20952000
   RFALEN := 6;                                                <<DS.00>>20954000
   TOS := "RFA ";                                              <<DS.00>>20956000
   TOS := 15;                                                  <<DS.00>>20958000
   TOS := RFAFILE;                                             <<DS.00>>20960000
   TOS := CODE;                                                <<DS.00>>20962000
   TOS := PARAM;                                               <<DS.00>>20964000
   MWCNOBUF;                                                   <<DS.00>>20966000
   IF <> THEN                                                  <<DS.00>>20968000
      BEGIN                                                    <<DS.00>>20970000
      TOS := 0;                                                <<DS.00>>20972000
      TOS := RFALINE;                                          <<DS.00>>20974000
      TOS := DSCHKPLABEL;                                      <<DS.00>>20976000
      ASMB(PCAL 0);                                            <<DS.00>>20978000
$  IF X1 = ON                                                  <<DS.00>>20980000
      IF <> THEN FTROUBLE(486);                                         20982000
$  IF                                                          <<DS.00>>20984000
      GO ERROR;                                                <<DS.00>>20986000
      END;                                                     <<DS.00>>20988000
   TOS := RFALEN -2;                                           <<DS.00>>20990000
   ASMB(SUBS 0);      << delete appendage >>                   <<DS.00>>20992000
   PARAM := TOS;                                               <<DS.00>>20994000
   CTLA := 0;     << no error >>                               <<DS.00>>20996000
   TOS := TOS.CC;                                              <<DS.00>>20998000
   CONDCODE := TOS;                                            <<DS.00>>21000000
   END;     << remote file >>                                           21002000
      << dummy 2 >>;                                                    21004000
      << dummy 3 >>;                                                    21006000
      << dummy 4 >>;                                                    21008000
      << dummy 5 >>;                                                    21010000
   BEGIN   << KSAM file >>                                              21012000
   KCONTROL(FILENUM,CODE,PARAM);                               <<KS.00>>21014000
   PUSH(STATUS);                                               <<KS.00>>21016000
   TOS := TOS.CC;                                              <<KS.00>>21018000
   CONDCODE := TOS;    << report condition code >>             <<KS.00>>21020000
   CTLA := 0;     << no error >>                               <<KS.00>>21022000
   GO GETOUT;                                                  <<KS.00>>21024000
   END;   << KSAM file >>                                      <<KS.00>>21026000
   <<DUMMY 7>>;                                                <<HM.00>>21028000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>21030000
   IF IOQX <> 0 AND CODE <> 43 THEN                            <<03038>>21032000
      BEGIN        << No-wait I/O pending. >>                  <<03038>>21034000
      TOS := IOPENDING;                                        <<03038>>21036000
      GO ERR                                                   <<03038>>21038000
      END;                                                     <<03038>>21040000
   CTLA:=0; CONDCODE:=CCE;                                     <<HM.00>>21042000
   IF CODE = 2 THEN                            <<QUIESCE I/O>> <<HM.00>>21044000
      TOS:=SUCCESSFUL                                          <<HM.00>>21046000
   ELSE IF CODE = 3 THEN                       <<READ HW STATUS  HM.00>>21048000
      BEGIN                                                    <<HM.00>>21050000
      JUNK:=DEVICESTATUS(ACB'DADDR);                           <<HM.00>>21052000
      IF < THEN GO E1;  <<ERROR?>>                             <<HM.00>>21054000
      TOG:=TRUE;  <<SET RETURN FLAG>>                          <<HM.00>>21056000
      TOS:=SUCCESSFUL;                                         <<HM.00>>21058000
      END                                                      <<HM.00>>21060000
   ELSE IF CODE = 4 THEN                       <<SET TIMEOUT>> <<HM.00>>21062000
      TOS:=FCCONTROL(0,PARAM)                                  <<HM.00>>21064000
   ELSE IF CODE = 6 THEN                       <<WRITE EOF?>>  <<HM.00>>21066000
      TOS:=FCWRITEOF(0,0)                                      <<HM.00>>21068000
   ELSE IF CODE = 43 THEN                      <<ABORT I/O?>>  <<HM.00>>21070000
      BEGIN                                                    <<HM.00>>21072000
      CASE FCABORTREQUESTS(0,0) OF                             <<HM.00>>21074000
         BEGIN                                                 <<HM.00>>21076000
         BEGIN  <<A PENDING REQUEST WAS ABORTED>>              <<HM.00>>21078000
         TOS:=SUCCESSFUL;                                      <<HM.00>>21080000
         END;                                                  <<HM.00>>21082000
         BEGIN  <<A REQUEST HAS ALREADY COMPLETED>>            <<HM.00>>21084000
         CTLA:=0; CONDCODE:=CCG;                               <<HM.00>>21086000
         TOS:=SUCCESSFUL;                                      <<HM.00>>21088000
         UNLOC'ACB(ACBMQ,0);                                   <<HM.00>>21090000
         GO EXIT1;                                             <<HM.00>>21092000
         END;                                                  <<HM.00>>21094000
         BEGIN  <<NO I/O WAS OUTSTANDING>>                     <<HM.00>>21096000
         TOS:=NOIOPENDING2;                                    <<HM.00>>21098000
         END;                                                  <<HM.00>>21100000
         END;  <<CASE>>                                        <<HM.00>>21102000
      END                                                      <<HM.00>>21104000
   ELSE IF LOWMSGVAL <= CODE <= HIMSGVAL THEN <<MSG SPECIFIC?>><<HM.00>>21106000
      TOS:=FCCONTROL(CODE-LOWMSGVAL+1,PARAM)                   <<HM.00>>21108000
   ELSE                                        <<INVALID CODE>><<HM.00>>21110000
      TOS:=DEVVIOL;                                            <<HM.00>>21112000
   IF S0 <> SUCCESSFUL THEN GO ERR;                            <<HM.00>>21114000
   UNLOC'ACB(ACBMQ,0);                                         <<HM.00>>21116000
   END;                                                        <<HM.00>>21118000
                                                               <<DS.00>>21120000
   END;       << FTYPE CASE >>                                          21122000
EXIT1:                                                         <<HM.00>>21124000
                                                                        21126000
   <<* * * Measurement data on FCONTROL * * *>>                         21128000
                                                                        21130000
$  IF X3 = ON                                                           21132000
   IF MEAS'TAPE'ON THEN BEGIN                                           21134000
   IF ACB'ACCCL = DIRACC THEN                                           21136000
      MMSTAT(EFCONTROL,FILENUM,CODE,0);                                 21138000
   END; << OF MEAS'TAPE'ON>>                                            21140000
$  IF                                                                   21142000
                                                                        21144000
   IF TOG THEN PARAM := JUNK;  << Return value to user >>               21146000
                                                                        21148000
GETOUT:                                                                 21150000
   RESETCRITICAL(CRIT);                                                 21152000
   ERROREXIT(3,CTLA,0);                                                 21154000
   END;     << procedure FCONTROL >>                                    21156000
$PAGE " FDEVICECONTROL "                                                21158000
PROCEDURE FDEVICECONTROL(FILENO,TARGET,TCOUNT,CTRL,P1,P2,ERRNUM);       21160000
VALUE FILENO,TCOUNT,P1,P2,CTRL;                                         21162000
INTEGER FILENO,TCOUNT,ERRNUM,CTRL;                                      21164000
LOGICAL P1,P2;                                                          21166000
ARRAY TARGET;                                                           21168000
OPTION PRIVILEGED;                                                      21170000
                                                               <<02556>>21172000
COMMENT -- FDEVICECONTROL is an extension  of  FCONTROL  which <<04321>>21174000
can  handle arrays (TARGET) to be passed to a device.  Control <<04321>>21176000
codes less than FDEVICECONTROL's range (%100-%377, 64-255) are <<04321>>21178000
passed to FCONTROL.  Any error there will be returned  through <<04321>>21180000
the ERRNUM parameter.                                          <<04321>>21182000
  FDEVICECONTROL has the following restrictions:               <<04321>>21184000
1.  DB must be at the stack (that is, no split-stack calls).   <<04321>>21186000
2.  Only conventional and remote files (or $NULL) are support- <<04321>>21188000
    ed by FDEVICECONTROL. FCONTROL also supports KSAM and mes- <<04321>>21190000
    sage files, and these will continue to be  supported  from <<04321>>21192000
    FDEVICECONTROL  when the CTRL parameter indicates FCONTROL <<04321>>21194000
    processing.                                                <<04321>>21196000
3.  CTRL must be in the range 0 to %77 (63) to cause an  FCON- <<04321>>21198000
    TROL  call,  or  %100-%377 (64-255) for processing by FDE- <<04321>>21200000
    VICECONTROL.  Some of these condes may not presently apply <<04321>>21202000
    to any device.                                             <<04321>>21204000
  Error handling in the preliminary processing deserves a word <<02556>>21206000
or two.  For an error to be reported by FCHECK it must  be  in <<02556>>21208000
ACB'ERROR of the ACB (or PXFOPEN for FOPEN's, but that doesn't <<02556>>21210000
concern us).  The ACB for remote files lives with the file  on <<02556>>21212000
the remote system. To log an error there, we must get at least <<02556>>21214000
as far as the remote file code below.  We remember  the  first <<02556>>21216000
error  we find, ignoring all others, until we can report it to <<02556>>21218000
the remote file (if FILENO is a remote  file).  If  FILENO  is <<02556>>21220000
not remote, the error is reported locally.  In either case the <<02556>>21222000
intrinsic terminates after the error is processed.             <<02556>>21224000
  As part of the intrinsic operation, any error (or  0  if  no <<02556>>21226000
error)  is returned in ERRNUM.  Well, almost any error.  If we <<02556>>21228000
were called in split-stack mode (illegal  because  ERRNUM  and <<02556>>21230000
TARGET are reference parameters) or if we detect a bounds vio- <<02556>>21232000
lation on ERRNUM we can't return anything there. To handle all <<02556>>21234000
situations, LOCAL'FAILURE (used by the remote  file  code)  is <<02556>>21236000
used as a three-way flag. A -1 indicates a bounds violation on <<02556>>21238000
ERRNUM until it can be remoted to any remote file. A value > 0 <<02556>>21240000
is the File System error code for Illegal DB.  Finally, LOCAL' <<02556>>21242000
FAILURE = 0 means that ERRNUM is valid, use it (ERRNUM will be <<02556>>21244000
0 if there is no error).                                       <<02556>>21246000
;                                                              <<02556>>21248000
   BEGIN                                                                21250000
   COMMENT:  Parameter definitions:                            <<02556>>21252000
                                                                        21254000
     FILENO      -     File number of an opened devicefile.    <<04321>>21256000
                                                                        21258000
     TARGET      -     Data to be written to the devicefile.   <<04321>>21260000
                                                                        21262000
     TCOUNT      -     +words or -bytes of data in Target.              21264000
                                                                        21266000
     CTRL   -     Code for the operation to be performed.               21268000
      < %100  -  Call FCONTROL with this control code.         <<04321>>21270000
        %100  -  Download VFC (2608A, 2608S, 2631 only)        <<04333>>21272000
         101  -  Download Left Margin (2608A, 2608S only)      <<04321>>21274000
         200  -  Select Primary/Secondary Character Set        <<04321>>21276000
         201  -  Select Logical Pages/Forms                             21278000
         202  -  Move Pen Relative                                      21280000
         203  -  Move Pen Absolute                                      21282000
         204  -  Define Job Characteristics                             21284000
         205  -  Download Physical Page Definition                      21286000
         206  -  Download/Delete Character Set                          21288000
         207  -  Download/Delete Forms                                  21290000
         210  -  Download Logical Page Table                            21292000
         211  -  Download Multi-Copy Form Overlay Table                 21294000
         212  -  Download/Delete VFC                           <<04333>>21296000
         213  -  Download/Delete Pictures                      <<04140>>21298000
         214  -  Page Control                                  <<02576>>21300000
         215  -  Clear Environment                                      21302000
         216  -  Job Start, callable only in priv mode because <<04321>>21304000
                   it can clear billing info (# pages printed).<<04321>>21306000
         217  -  Load default Environment                               21308000
         220  -  Print Pictures                                <<04140>>21310000
         222  -  Set/clear device extended capability mode.    <<04321>>21312000
                                                                        21314000
           All other CTRL's return an OPERATION INCONSISTENT   <<04321>>21316000
             WITH DEVICE TYPE error.                           <<04321>>21318000
                                                                        21320000
     P1          -     Additional control information...       <<02556>>21322000
                                                                        21324000
     P2          -     ... varies depending on CTRL.           <<02556>>21326000
                                                                        21328000
     ERRNUM      -     Returns error number.                            21330000
         126  -  ILL'CHAR'SET   - Character set number must be <<02556>>21332000
                                    between 0 and 31.          <<02556>>21334000
         127  -  ILL'FORM       - Form number must be between  <<02556>>21336000
                                    0 and 31.                  <<02556>>21338000
         128  -  ILL'LOG'PAGE   - Logical page number must be  <<02556>>21340000
                                    between 0 and 31.          <<02556>>21342000
         129  -  ILL'VFC        - Vertical format number must  <<02556>>21344000
                                    be between 0 and 31.       <<02556>>21346000
         130  -  ILL'NUMCOPIES  - Number of copies must be     <<02556>>21348000
                                    tween 1 and 32767.         <<02556>>21350000
         131  -  ILL'OVERLAY    - Number of overlays must be   <<02556>>21352000
                                    between 1 and 8.           <<02556>>21354000
         132  -  ILL'PAGELENGTH - Page length parameter must   <<02556>>21356000
                                    be between 12 (=3") and    <<02556>>21358000
                                    68 (=17").                 <<02556>>21360000
         133  -  ILL'PICTURE    - Picture number must be       <<04140>>21362000
                                  between 0 and 31.            <<04140>>21364000
         134  -  SET'OR'CLEAR   - Parameter must be 1 (set) or <<04321>>21366000
                                    or 0 (clear).              <<04321>>21368000
         or other FSERR (e.g., BNDVIOL, ILLDB, etc.).  If      <<02556>>21370000
         FDEVICECONTROL discovers a bounds violation on the    <<02556>>21372000
         ERRNUM parameter itself, it is not changed.           <<02556>>21374000
                                                                        21376000
                                                                        21378000
      Conditions Codes:                                                 21380000
      CCE - No error, ERRNUM := 0.                             <<02556>>21382000
      CCL - Error, ERRNUM := FSERR (or not modified if error   <<02556>>21384000
              is bounds violation on ERRNUM itself).           <<02556>>21386000
;                                                              <<02556>>21388000
                                                                        21390000
EQUATE                                                         <<02556>>21392000
  DOWNLOAD'VFC = %100,   << ATTACHIO function code.         >> <<04482>>21394000
  MAX'FDEVCTRL = %377,   << Maximum value of CTRL parameter >> <<04321>>21396000
  MIN'FDEVCTRL = %100,   << Minimum value of CTRL parameter >> <<04321>>21398000
  REMOTE'FILE  =    1;   << File type of remote file.       >> <<02556>>21400000
   EQUATE UBND = -11;  <<Q rel upper bound for bounds check>>  <<03059>>21402000
   INTEGER                                                              21404000
      LDEV,           << Logical device number of FILENO.   >> <<04333>>21406000
      SENDCOUNT;                                                        21408000
                                                                        21410000
   LOGICAL                                                     <<04321>>21412000
      CRIT,                                                    <<04321>>21414000
      DEVICE'FLAGS;   << Environment requirements for CTRL. >> <<04333>>21416000
   LOGICAL POINTER TARGET'PT;                                           21420000
                                                               <<02556>>21422000
<< Remote File Access (RFA) variables.                      >> <<02556>>21424000
                                                               <<02556>>21426000
INTEGER POINTER                                                <<02556>>21428000
  RFAPTR;           << Message array (appendage) pointer.   >> <<02556>>21430000
                                                               <<02556>>21432000
INTEGER                                                        <<02556>>21434000
  RFALEN;           << Length of appendage.                 >> <<02556>>21436000
                                                               <<02556>>21438000
LOGICAL                                                        <<02556>>21440000
  LOCAL'FAILURE;    << Error code to be entered in remote   >> <<02556>>21442000
                    << file's ACB'ERROR for use by FCHECK.  >> <<02556>>21444000
                                                                        21446000
 << Following LOC'ACB params must be last and in order: >>              21448000
   INTEGER ACBMQ;                                              <<04591>>21450000
   INTEGER AFTE;                                               <<02556>>21452000
   INTEGER PACBV;                                              <<02556>>21454000
   INTEGER LACBV;                                              <<02556>>21456000
   INTEGER IOQX;                                               <<02556>>21458000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;   << Q+13 >>           <<04321>>21460000
   BUILD'ACB;                                                           21462000
   INTEGER ACB'CTL      = ACB+11;                                       21464000
   INTEGER ACB'SPTYRC   = ACB+40;                                       21466000
   LOGICAL ACB'X1       = ACB+46;                                       21468000
   LOGICAL ACB'X2       = ACB+47;                                       21470000
   INTEGER DSTX;                                                        21472000
 << end of LOC'ACB params >>                                            21474000
                                                                        21476000
   DEFINE INTRINEXIT = [10/0,6/7] #,                                    21478000
          BIT0       =(0:1)#,                                  <<02556>>21480000
          BIT1       =(1:1)#,                                  <<02556>>21482000
          BIT3       =(3:1)#,                                  <<02556>>21484000
          BIT4       =(4:1)#,                                  <<02556>>21486000
          LOWER'BYTE =(8:8)#,                                  <<02556>>21488000
          UPPER'BYTE =(0:8)#,                                  <<02556>>21490000
          MUST'BE'HOT     = DEVICE'FLAGS.(14:1)#,              <<04321>>21492000
          MUST'BE'SPOOLED = DEVICE'FLAGS.(13:1)#,              <<04321>>21494000
          MUST'BE'PRIV    = DEVICE'FLAGS.(15:1)#;              <<04333>>21496000
                                                               <<02556>>21500000
SUBROUTINE CHECK'PREVIOUS'ERROR (THIS'ERROR);                  <<02556>>21502000
  VALUE THIS'ERROR;  INTEGER THIS'ERROR;                       <<02556>>21504000
                                                               <<02556>>21506000
BEGIN COMMENT -- checks for existence of a previously-detected <<02556>>21508000
error and sets the error code from  THIS'ERROR  if  none.  The <<02556>>21510000
tests must be in the order shown.                              <<02556>>21512000
;                                                              <<02556>>21514000
IF LOCAL'FAILURE = 0 AND ERRNUM = 0 THEN ERRNUM := THIS'ERROR; <<02556>>21516000
END;   << of CHECK'PREVIOUS'ERROR.                          >> <<02556>>21518000
                                                               <<02556>>21520000
                                                               <<02556>>21522000
INTEGER SUBROUTINE GET'ERROR;                                  <<02556>>21524000
                                                                        21526000
BEGIN COMMENT -- Returns  the  appropriate  error  code  after <<02556>>21528000
testing LOCAL'FAILURE for bounds violation or split-stack call.<<02556>>21530000
;                                                              <<02556>>21532000
GET'ERROR := IF LOCAL'FAILURE = %177777                        <<02556>>21534000
  THEN BNDVIOL   << on ERRNUM                               >> <<02556>>21536000
  ELSE IF LOCAL'FAILURE = 0                                    <<02556>>21538000
    THEN ERRNUM   << ERRNUM O.K.                            >> <<02556>>21540000
    ELSE LOCAL'FAILURE;   << We were called in split-stack. >> <<02556>>21542000
END;   << of GET'ERROR.                                        <<02556>>21544000
                                                               <<02556>>21546000
                                                               <<02556>>21548000
   ERRORON;                                                             21550000
   CRIT := SETCRITICAL;                                                 21552000
   LOCAL'FAILURE := 0;                                         <<02556>>21554000
   TOS := FBNDCHK (@ERRNUM, 1, UBND);                          <<03059>>21556000
   IF S0 = 1                                                            21558000
     THEN   << Split-stack call, put it on hold.            >> <<02556>>21560000
        BEGIN                                                  <<02556>>21562000
        DEL;                                                   <<02556>>21564000
        LOCAL'FAILURE := ILLDB;                                <<02556>>21566000
        END                                                    <<02556>>21568000
     ELSE                                                      <<02556>>21570000
        BEGIN   << Not a split-stack call.                  >> <<02556>>21572000
        IF NOT TOS                                             <<02556>>21574000
          THEN LOCAL'FAILURE := %177777   << BV on ERRNUM.  >> <<02556>>21576000
          ELSE ERRNUM := 0;   << Everything's rosy.         >> <<02556>>21578000
        IF FBNDVIOL (@TARGET, TCOUNT, UBND) THEN               <<03059>>21580000
          CHECK'PREVIOUS'ERROR (BNDVIOL);                      <<02556>>21582000
        IF CTRL < MIN'FDEVCTRL   << Assume FCONTROL call... >> <<04321>>21584000
           THEN IF GET'ERROR = 0  << if no errors yet.      >> <<04321>>21586000
              THEN BEGIN                                       <<04321>>21588000
                   FCONTROL (FILENO, CTRL, TARGET);            <<04321>>21590000
                                                               <<04321>>21592000
  COMMENT -- The FCHECK call below may return bum data if  the <<04321>>21594000
FCONTROL  error  is a local error but FILENO is a remote file. <<04321>>21596000
This is because FCONTROL does not put its local error code  in <<04321>>21598000
the  remote file's ACB, where FCHECK looks for it.  The kludgy <<04321>>21600000
%100000 assures that we return CCL in this  case  (at  EXIT0). <<04321>>21602000
If FCONTROL is ever fixed, that statement (and these comments) <<04321>>21604000
can be deleted.                                                <<04321>>21606000
;                                                              <<04321>>21608000
                   IF <> THEN                                  <<04321>>21610000
                      BEGIN                                    <<04321>>21612000
                      FCHECK (FILENO, ERRNUM);                 <<04321>>21614000
                      IF ERRNUM = 0 THEN ERRNUM := %100000;    <<04321>>21616000
                      END;                                     <<04321>>21618000
                   GO TO EXIT0;                                <<04321>>21620000
                   END    << of FCONTROL call.              >> <<04321>>21622000
              ELSE   << Previous error, can't do FCONTROL.  >> <<04321>>21624000
           ELSE      << Not in FCONTROL range.              >> <<04321>>21626000
              IF NOT (MIN'FDEVCTRL <= CTRL <= MAX'FDEVCTRL)    <<04321>>21628000
                 THEN CHECK'PREVIOUS'ERROR (INVOP);            <<04321>>21630000
        END;   << Not a split-stack call.                   >> <<02556>>21632000
                                                               <<02556>>21634000
COMMENT -- LOC'ACB is one of those strange beasts which return <<02556>>21636000
values via a partial cutback of the parameter stack.  The rea- <<02556>>21638000
son is that it may be called in split-stack mode,  making  re- <<02556>>21640000
ference parameters impossible.  In this case, the first param- <<02556>>21642000
eter in the list is ignored but holds a  place  for  a  return <<02556>>21644000
value.  The same result could be obtained more cleanly by mak- <<02556>>21646000
ing LOC'ACB a typed procedure.  Maybe another time...          <<02556>>21648000
;                                                              <<02556>>21650000
   GET'ACB'Q'LOC;                                              <<04591>>21652000
   LOC'ACB (0, ACBMQ, FILENO, UMODE);                          <<02556>>21654000
   DSTX := TOS;                                                <<02556>>21656000
   IF < THEN                                                   <<02642>>21658000
      BEGIN   << Invalid file number.                       >> <<02642>>21660000
      CHECK'PREVIOUS'ERROR (INVFN);                            <<02556>>21662000
      GO TO EXIT0;                                             <<02556>>21664000
      END;    << of invalid file number.                    >> <<02642>>21666000
   IF > THEN GO TO EXIT0;   << $NULL.                       >> <<02642>>21668000
                                                               <<02556>>21670000
   IF DSTX <> 0 THEN CHECK'PREVIOUS'ERROR (ILLDB);             <<02556>>21672000
   IF FTYPE > REMOTE'FILE THEN                                 <<02556>>21674000
      BEGIN   << Only normal and remote files supported.    >> <<02556>>21676000
      CHECK'PREVIOUS'ERROR (UNIMPL);                           <<02556>>21678000
      IF FTYPE = MSG'TYPE THEN                                 <<02556>>21680000
         BEGIN                                                 <<02556>>21682000
STUFF'ACB:                                                     <<02556>>21684000
         ACB'ERROR := GET'ERROR;                               <<02556>>21686000
         GO RELACB;                                            <<02556>>21688000
         END;                                                  <<02556>>21690000
      GO TO EXIT0;                                             <<02556>>21692000
      END;    << of illegal file type.                      >> <<02556>>21694000
                                                               <<02556>>21696000
   CASE * FTYPE OF                                             <<02556>>21698000
    BEGIN                                                      <<02556>>21700000
                                                               <<02556>>21702000
      BEGIN   << 0 -- conventional file.                    >> <<02556>>21704000
      IF GET'ERROR <> 0 THEN GO STUFF'ACB;                     <<04321>>21706000
                                                                        21708000
  COMMENT -- This next call was designed to remove all  device <<04333>>21710000
and  environment  dependencies  from  FDEVICECONTROL and place <<04333>>21712000
them in a lower level access routine where other  callers  can <<04333>>21714000
access them too.  Maintenance and enhancements are much easier <<04333>>21716000
this way as well.  You call with an LDEV number and  the  CTRL <<04333>>21718000
code.  It returns a bit mask of required environments.  If the <<04333>>21720000
LDEV does not support a particular CTRL, VALIDDEVTYPE  returns <<04333>>21722000
FALSE.                                                         <<04333>>21724000
  For example, if LDEV is a 2680, the bit mask will  return  a <<04333>>21726000
requirement  that  the  device  be spooled.  If CTRL is one of <<04333>>21728000
those that reads status or an environment from the device, the <<04333>>21730000
bit mask will state that the device must be unspooled, or hot, <<04333>>21732000
since reads from a spooled device are not meaningful.          <<04333>>21734000
  If the device is spooled, CTRL may only be supported on some <<04333>>21736000
devices in its class.  To prevent VALIDDEVTYPE from  returning <<04333>>21738000
an error, LDEV is set to -1. This alerts VALIDDEVTYPE to check <<04333>>21740000
only that CTRL is supported on some device. This imposes other <<04333>>21742000
restrictions as well.  See the comments  in  VALIDDEVTYPE  for <<04333>>21744000
further details.                                               <<04333>>21746000
;                                                              <<04321>>21748000
     IF ACB'SPOOLED                                            <<04333>>21750000
        THEN LDEV := -1                                        <<04333>>21752000
        ELSE LDEV := ACB'DADDR;                                <<04333>>21754000
     IF NOT VALIDDEVTYPE (LDEV, CTRL, DEVICE'FLAGS) THEN       <<04333>>21756000
        CHECK'PREVIOUS'ERROR (DEVVIOL);                        <<04333>>21758000
     IF ACB'SPOOLED AND MUST'BE'HOT THEN                       <<04321>>21760000
        CHECK'PREVIOUS'ERROR (SPOOLILLOP);                     <<04321>>21762000
     IF NOT ACB'SPOOLED AND MUST'BE'SPOOLED THEN               <<04321>>21764000
        CHECK'PREVIOUS'ERROR (SPOOLDEVDOWN);                   <<04321>>21766000
     IF NOT (PRIVMODE) AND MUST'BE'PRIV THEN                   <<04321>>21768000
        CHECK'PREVIOUS'ERROR (ILLCAP);                         <<04321>>21770000
     IF ERRNUM <> 0 THEN GO TO NFG;                            <<04321>>21772000
                                                                        21774000
      IF TCOUNT < 0 THEN TCOUNT := (1-TCOUNT)&LSR(1);          <<02556>>21776000
      ACB'X1 := P1;                                            <<02556>>21778000
      ACB'X2 := P2;                                            <<02556>>21780000
      @TARGET'PT := @TARGET;                                   <<02556>>21782000
                                                               <<04333>>21784000
<< Split relevant codes into ranges of %100.                >> <<04333>>21786000
                                                               <<04333>>21788000
      IF (MIN'FDEVCTRL <= CTRL <= %177) THEN                   <<04333>>21790000
         CASE * CTRL - %100 OF                                 <<04333>>21792000
          BEGIN                                                <<04333>>21794000
            BEGIN    << %100 - 2608A/2608S/2631 Download VFC>> <<04333>>21796000
            END;                                               <<04333>>21798000
                                                               <<04333>>21800000
            BEGIN    << %101 - 2608A/2608S Dwnld left mrgn. >> <<04333>>21802000
            END;                                               <<04333>>21804000
                                                               <<04333>>21806000
            ;;;;;;   << %102 - %107 reserved.               >> <<04333>>21808000
            ;;;;;;;; << %110 - %117 reserved.               >> <<04333>>21810000
            ;;;;;;;; << %120 - %127 reserved.               >> <<04333>>21812000
            ;;;;;;;; << %130 - %137 reserved.               >> <<04333>>21814000
            ;;;;;;;; << %140 - %147 reserved.               >> <<04333>>21816000
            ;;;;;;;; << %150 - %157 reserved.               >> <<04333>>21818000
            ;;;;;;;; << %160 - %167 reserved.               >> <<04333>>21820000
            ;;;;;;;; << %170 - %177 reserved.               >> <<04333>>21822000
          END     << %100-%177 CASE                         >> <<04333>>21824000
      ELSE IF (%200 <= CTRL <= %277) THEN                      <<04333>>21826000
                                                               <<04333>>21828000
      CASE * CTRL-%200 OF                                      <<02556>>21830000
      BEGIN                                                             21832000
         BEGIN         << %200 - select character set >>                21834000
         IF P1.LOWER'BYTE > 31 OR P2.LOWER'BYTE > 31 THEN      <<02556>>21836000
            BEGIN                                                       21838000
            ERRNUM := ILL'CHAR'SET;                            <<02556>>21840000
NFG:        ACB'ERROR := ERRNUM;                               <<02556>>21842000
            GO RELACB;                                         <<02556>>21844000
            END;                                                        21846000
         END;                                                           21848000
                                                                        21850000
         BEGIN        << %201 - logical page selection >>               21852000
         IF P1.BIT0 AND P2.UPPER'BYTE > 31                     <<02556>>21854000
           OR P1.BIT1 AND P2.LOWER'BYTE > 31 THEN              <<02556>>21856000
            BEGIN                                                       21858000
            ERRNUM := ILL'LOG'PAGE;                            <<02556>>21860000
            GO NFG;                                                     21862000
            END;                                                        21864000
         END;                                                           21866000
                                                                        21868000
         BEGIN        << %202 - move pen relative >>                    21870000
         END;                                                           21872000
                                                                        21874000
         BEGIN        << %203 - move pen absolute >>                    21876000
         END;                                                           21878000
                                                                        21880000
         BEGIN        << %204 - define Job characteristics >>           21882000
         IF P1.BIT1 AND (P2 = 0 OR P2.BIT0) THEN               <<02556>>21884000
            BEGIN   << Too many (or 0) copies specified.    >> <<02556>>21886000
            ERRNUM := ILL'NUMCOPIES;                           <<02556>>21888000
            GO TO NFG;                                         <<02556>>21890000
            END;                                               <<02556>>21892000
         END;                                                           21894000
                                                                        21896000
         BEGIN  << %205 - download phys page & multi-copy overlay >>    21898000
         IF P1.BIT3 AND NOT (12 <= INTEGER (P1.LOWER'BYTE) <=  <<02556>>21900000
           68) THEN                                            <<02556>>21902000
            BEGIN  << Redefining page length w/ illgl lngth >> <<02556>>21904000
            ERRNUM := ILL'PAGELENGTH;                          <<02556>>21906000
            GO TO NFG;                                         <<02556>>21908000
            END;                                               <<02556>>21910000
         IF P1.BIT4 AND (P2 = 0 OR P2.BIT0) THEN               <<02556>>21912000
            BEGIN   << Redefining max copies w/ illgl num.  >> <<02556>>21914000
            ERRNUM := ILL'NUMCOPIES;                           <<02556>>21916000
            GO TO NFG;                                         <<02556>>21918000
            END;                                               <<02556>>21920000
         END;                                                           21922000
                                                                        21924000
         BEGIN      << %206 - download/delete character set >> <<02556>>21926000
         IF  P2.LOWER'BYTE > 31 THEN                           <<02556>>21928000
            BEGIN    << character set nr. out of range >>               21930000
            ERRNUM := ILL'CHAR'SET;                            <<02556>>21932000
            GO NFG;                                                     21934000
            END;                                                        21936000
         END;                                                           21938000
                                                                        21940000
         BEGIN        << %207 - download/delete form >>                 21942000
         IF P2.LOWER'BYTE > 31 THEN                            <<02556>>21944000
            BEGIN                                                       21946000
            ERRNUM := ILL'FORM;                                <<02556>>21948000
            GO NFG;                                                     21950000
            END;                                                        21952000
         END;                                                           21954000
                                                                        21956000
         BEGIN        << %210 - download logical page table >>          21958000
         END;                                                           21962000
                                                                        21964000
         BEGIN        << %211 - download multi-copy form overlay >>     21966000
         IF NOT (1 <= TCOUNT <= 8) THEN                                 21968000
            BEGIN    << no more than 8 overlays. >>                     21970000
            ERRNUM := ILL'OVERLAY;                             <<02556>>21972000
            GO NFG;                                                     21974000
            END;                                                        21976000
         END;                                                           21978000
                                                                        21980000
         BEGIN       << %212 - Download/Delete VFC.         >> <<04333>>21982000
         IF P2.LOWER'BYTE > 31 THEN                            <<02556>>21984000
            BEGIN      << VFC number out of range. >>                   21986000
            ERRNUM := ILL'VFC;                                 <<02556>>21988000
            GO TO NFG;                                         <<02556>>21990000
            END;                                                        21996000
         END;                                                           21998000
                                                                        22000000
         BEGIN       << %213 - Download/Delete Picture >>      <<04140>>22002000
         IF P2.LOWER'BYTE > 31 THEN                            <<04140>>22004000
            BEGIN    << picture number out of range >>         <<04140>>22006000
            ERRNUM := ILL'PICTURE;                             <<04140>>22008000
            GO TO NFG;                                         <<04140>>22010000
            END;                                               <<04140>>22012000
         END;                                                  <<04140>>22014000
                                                                        22016000
         BEGIN        << %214 - page control                >> <<02576>>22018000
         IF P2.LOWER'BYTE > 31 THEN                            <<02576>>22020000
            BEGIN                                              <<02576>>22022000
            ERRNUM := ILL'LOG'PAGE;                            <<02576>>22024000
            GO TO NFG;                                         <<02576>>22026000
            END;                                               <<02576>>22028000
         END;                                                  <<02576>>22030000
                                                                        22032000
         BEGIN       << %215 - clear Environment >>            <<02556>>22034000
         END;                                                           22036000
                                                                        22038000
         BEGIN       << %216 - Job Open                     >> <<04321>>22040000
         END;                                                  <<04321>>22042000
                                                                        22044000
         BEGIN       << %217 - load default Environment >>     <<02556>>22046000
         END;                                                           22048000
                                                               <<04140>>22050000
         BEGIN       << %220 - Print Picture >>                <<04140>>22052000
         IF P1.BIT0 AND P2.LOWER'BYTE > 31 THEN                <<04140>>22054000
            BEGIN  << picture number > 31 -- out of range >>   <<04140>>22056000
            ERRNUM := ILL'PICTURE;                             <<04140>>22058000
            GO TO NFG;                                         <<04140>>22060000
            END;                                               <<04140>>22062000
         END;                                                  <<04140>>22064000
                                                                        22066000
         BEGIN       << %221 = 145 - End of Job             >> <<04321>>22068000
         END;                                                  <<04321>>22070000
                                                               <<04321>>22072000
         BEGIN       << %222 = 146 - Device extended capa-  >> <<04321>>22074000
                     <<              bility mode.           >> <<04321>>22076000
         IF P1 > 1 THEN                                        <<04321>>22078000
            BEGIN   << 1 = set, 0 = clear, others illegal.  >> <<04321>>22080000
            ERRNUM := SET'OR'CLEAR;                            <<04321>>22082000
            GO TO NFG;                                         <<04321>>22084000
            END;                                               <<04321>>22086000
         END;                                                  <<04321>>22088000
      END        << %200-%277 CASE                          >> <<04333>>22090000
                                                               <<04333>>22092000
      ELSE CASE * CTRL - %300 OF                               <<04333>>22094000
            BEGIN                                              <<04333>>22096000
              ;;;;;;;; << %300 - %307 reserved.             >> <<04333>>22098000
              ;;;;;;;; << %310 - %317 reserved.             >> <<04333>>22100000
              ;;;;;;;; << %320 - %327 reserved.             >> <<04333>>22102000
              ;;;;;;;; << %330 - %337 reserved.             >> <<04333>>22104000
              ;;;;;;;; << %340 - %347 reserved.             >> <<04333>>22106000
              ;;;;;;;; << %350 - %357 reserved.             >> <<04333>>22108000
              ;;;;;;;; << %360 - %367 reserved.             >> <<04333>>22110000
                                                               <<04333>>22112000
              BEGIN   << %370 - Kanji function, no parms.   >> <<04333>>22114000
              END;                                             <<04333>>22116000
                                                               <<04333>>22118000
              BEGIN   << %371 - Kanji function, no parms.   >> <<04333>>22120000
              END;                                             <<04333>>22122000
                                                               <<04333>>22124000
              BEGIN   << %372 - Kanji function, no parms.   >> <<04333>>22126000
              END;                                             <<04333>>22128000
                                                               <<04333>>22130000
              BEGIN   << %373 - Kanji function, no parms.   >> <<04333>>22132000
              END;                                             <<04333>>22134000
                                                               <<04333>>22136000
              BEGIN   << %374 - Kanji function, no parms.   >> <<04333>>22138000
              END;                                             <<04333>>22140000
                                                               <<04333>>22142000
              BEGIN   << %375 - Kanji function, no parms.   >> <<04333>>22144000
              END;                                             <<04333>>22146000
                                                               <<04333>>22148000
              BEGIN   << %376 - Kanji function, no parms.   >> <<04333>>22150000
              END;                                             <<04333>>22152000
                                                               <<04333>>22154000
              BEGIN   << %377 - Kanji function, no parms.   >> <<04333>>22156000
              END;                                             <<04333>>22158000
            END;   << %300 - %377 CASE.                     >> <<04333>>22160000
                                                               <<04321>>22162000
      IF ACB'SPOOLED                                           <<04321>>22164000
         THEN                                                  <<04321>>22166000
            BEGIN                                              <<04321>>22168000
                                                                        22170000
    << Write data out to spoofle. >>                                    22172000
                                                                        22174000
<< 2608x printers don't support the continuation record pro->> <<04482>>22176000
<< tocol the way the 2680 does.  This means that VFC  down- >> <<04482>>22178000
<< loads  must  be done in one record.  To achieve this, we >> <<04482>>22180000
<< fool both this code and IOMOVE by temporarily  expanding >> <<04482>>22182000
<< the  size of ACB'SPREC to larger than the largest possi- >> <<04482>>22184000
<< ble VFC file.  The VFC download function is not valid on >> <<04482>>22186000
<< the 2680. If used, it will be caught when the spoofle is >> <<04482>>22188000
<< printed.  Note that this problem doesn't arise  for  hot >> <<04482>>22190000
<< devices  (below),  because  they  get the entire TCOUNT. >> <<04482>>22192000
<< This code is a short-term fix, and  should  be  replaced >> <<04482>>22194000
<< when a better long-term solution is available.           >> <<04482>>22196000
                                                               <<04482>>22198000
            DEVICE'FLAGS := ACB'SPREC;   << Temp store.     >> <<04482>>22200000
            IF CTRL = DOWNLOAD'VFC THEN ACB'SPREC := 500;      <<04482>>22202000
            SENDCOUNT := (ACB'SPREC-8)&LSR(1);                          22204000
            ACB'CTL := %320;  << Don't kill trailing blanks >>          22206000
                                                                        22208000
            DO BEGIN                                                    22210000
               IF SENDCOUNT > TCOUNT THEN SENDCOUNT := TCOUNT;          22212000
                                                               <<02556>>22214000
<< No values may be stacked when IOMOVE is called.          >> <<02556>>22216000
                                                               <<02556>>22218000
               IOMOVE(CTRL,TARGET'PT,SENDCOUNT);                        22220000
               IF ACB'STATUS <> 1 THEN                                  22222000
                  BEGIN                                                 22224000
                  ERRNUM := ACB'ERROR;                                  22226000
                                                               <<02578>>22228000
<< The following kludge assures returning  CCL  on  an  EOF >> <<02578>>22230000
<< error (FSERR 0).                                         >> <<02578>>22232000
                                                               <<02578>>22234000
                  IF ERRNUM = 0 THEN ERRNUM := %100000;                 22236000
                  GO RELACB;                                            22238000
                  END;                                                  22240000
                                                                        22242000
               ACB'X2.(0:1) := 1;    << continuation record >>          22244000
               @TARGET'PT := @TARGET'PT+SENDCOUNT;                      22246000
               TCOUNT := TCOUNT-SENDCOUNT;                              22248000
               END UNTIL <=;                                            22250000
            ACB'SPREC := DEVICE'FLAGS;                         <<04482>>22252000
            END   << of spooled output.                     >> <<04321>>22254000
         ELSE                                                  <<04321>>22256000
            BEGIN   << Non-spooled (hot) output device.     >> <<04321>>22258000
                                                               <<04321>>22260000
<< No values may be stacked when FQUIESCE'IO is called.     >> <<04321>>22262000
                                                               <<04321>>22264000
            IF NOT ACB'INHIBITBUF THEN FQUIESCE'IO (0);        <<04321>>22266000
            TOS := ATTACHIO (ACB'DADDR,   << LDEV number    >> <<04321>>22268000
                             0,           << QMISC          >> <<04321>>22270000
                             0,           << Dataseg #      >> <<04321>>22272000
                                          <<   (0 = stack)  >> <<04321>>22274000
                             @TARGET,     << DB-rel offset  >> <<04321>>22276000
                                          <<   in dataseg   >> <<04321>>22278000
                             CTRL,        << Function code  >> <<04321>>22280000
                             TCOUNT,                           <<04321>>22282000
                             P1,                               <<04321>>22284000
                             P2,                               <<04321>>22286000
                             BFLAGS);                          <<04321>>22288000
            DEL;               << Don't need TLOG.          >> <<04321>>22290000
            ACB'STATUS := S0;  << Should save status though >> <<04321>>22292000
            IF TOS.GENERAL'STATUS <> NO'ERR'STAT THEN          <<04321>>22294000
               BEGIN                                           <<04321>>22296000
               ERRNUM := ACB'ERROR := IOSTAT (ACB'STATUS);     <<04321>>22298000
                                                               <<04321>>22300000
<< The following kludge assures returning  CCL  on  an  EOF >> <<04321>>22302000
<< error (FSERR 0).                                         >> <<04321>>22304000
                                                               <<04321>>22306000
               IF ERRNUM = 0 THEN ERRNUM := %100000;           <<04321>>22308000
               END;                                            <<04321>>22310000
            END;   << Non-spooled (hot) output device.      >> <<04321>>22312000
                                                               <<04321>>22314000
RELACB:                                                                 22316000
      UNLOC'ACB(ACBMQ,0);                                               22318000
EXIT0:                                                         <<02556>>22320000
      TOS := GET'ERROR;                                        <<02556>>22322000
      IF S0 = 0 THEN TOS := CCE ELSE TOS := CCL;               <<02556>>22324000
      S1 := S1 & LSL(1) & LSR(1);  << Clear bit0 if temp EOF>> <<02578>>22326000
      END;    << 0 -- conventional file.                    >> <<02556>>22328000
                                                               <<02556>>22330000
      BEGIN   << 1 -- remote file.                          >> <<02556>>22332000
COMMENT --                                                     <<02556>>22334000
  This section builds the message array for the  DS  interface <<02556>>22336000
procedure  MANAGEWRITECONVERSATION,  calls  the  procedure and <<02556>>22338000
then processes the results.  In keeping with the other intrin- <<02556>>22340000
sics, the message array will be built on the top of stack, al- <<02556>>22342000
though maintenance of such a structure can be quite difficult. <<02556>>22344000
The other side of the coin is that the array is allocated only <<02556>>22346000
when needed (that is, for accessing a remote file), thus  con- <<02556>>22348000
serving the stack.                                             <<02556>>22350000
  The DS software allocates us one record's  worth  of  buffer <<02556>>22352000
space,  based on the record size of the spoofle at FOPEN time. <<02556>>22354000
Since our remote requests may involve  larger  size  transfers <<02556>>22356000
(which  the  remote  FDEVICECONTROL  will  break  into smaller <<02556>>22358000
units), we must structure them in a  manner  similar  to  that <<02556>>22360000
used by the remote FWRITE code for multi-record transfers.  We <<02556>>22362000
require two calls to the DS interface  procedure  MANAGEWRITE- <<02556>>22364000
CONVERSATION. The first call passes the message array (append- <<02556>>22366000
age) which includes the total transfer length but  a  0-length <<02556>>22368000
transfer  in  the  MANAGEWRITECONVERSATION  call itself.  This <<02556>>22370000
alerts the DS code to allocate a buffer large enough  to  hold <<02556>>22372000
the  transfer  but  does not perform the transfer itself.  The <<02556>>22374000
second call does not require an  appendage  but  includes  the <<02556>>22376000
proper length in the MANAGEWRITECONVERSATION call.             <<02556>>22378000
  The fully-built stack (just before the first call to MANAGE- <<02556>>22380000
WRITECONVERSATION) looks like this:                            <<02556>>22382000
                                                               <<02556>>22384000
    +-------------------------------+                          <<02556>>22386000
    | Message array (appendage) for |                          <<02556>>22388000
    | MANAGEWRITECONVERSATION       |                          <<02556>>22390000
    | (see below)                   |                          <<02556>>22392000
    +-------------------------------+                          <<02556>>22394000
    | DS parameters                 | \                        <<02556>>22396000
    | . . . . . . . . . . . . . . . |  \                       <<02556>>22398000
    | @appendage (stack-DB-relative)|   |                      <<02556>>22400000
    | . . . . . . . . . . . . . . . |   |                      <<02556>>22402000
    | Length of appendage           |   |                      <<02556>>22404000
    | . . . . . . . . . . . . . . . |   |  MANAGEWRITE         <<02556>>22406000
    | @data array TO remote (TARGET)|    > CONVERSATION        <<02556>>22408000
    | . . . . . . . . . . . . . . . |   |  parameters          <<02556>>22410000
    | Length of TO array (TCOUNT)   |   |                      <<02556>>22412000
    | . . . . . . . . . . . . . . . |   |                      <<02556>>22414000
    | @data array FROM remote (0)   |   |                      <<02556>>22416000
    | . . . . . . . . . . . . . . . |  /                       <<02556>>22418000
    | Length of FROM array (0)      | /                        <<02556>>22420000
    +-------------------------------+                          <<02556>>22422000
                                                               <<02556>>22424000
  Detail of message array for MANAGEWRITECONVERSATION:         <<02556>>22426000
                                                               <<02556>>22428000
                         1 1 1 1 1 1                           <<02556>>22430000
     0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5      WORD                 <<02556>>22432000
    +---------------+---------------+                          <<02556>>22434000
    |      "R"      |      "F"      |       0                  <<02556>>22436000
    +---------------+---------------+                          <<02556>>22438000
    |      "A"      |     blank     |       1                  <<02556>>22440000
    +---------------+---------------+                          <<02556>>22442000
    | LOCAL'FAILURE | FDEVICECONTROL|       2                  <<02556>>22444000
    |               | DS-code (=%65)|                          <<02556>>22446000
    +---------------+---------------+                          <<02556>>22448000
    | RFA file number               |       3                  <<02556>>22450000
    +-------------------------------+                          <<02556>>22452000
    | TCOUNT parameter              |       4                  <<02556>>22454000
    +-------------------------------+                          <<02556>>22456000
    | CTRL (controlcode) parameter  |       5                  <<02556>>22458000
    +-------------------------------+                          <<02556>>22460000
    | P1 parameter                  |       6                  <<02556>>22462000
    +-------------------------------+                          <<02556>>22464000
    | P2 parameter                  |       7                  <<02556>>22466000
    +-------------------------------+                          <<02556>>22468000
                                                               <<02556>>22470000
The DS interface generates three reply structures:             <<02556>>22472000
  a)  A Head Section, used only by DS, which we never see.     <<02556>>22474000
  b)  An Appendage  section  consisting  only  of  the  remote <<02556>>22476000
      FDEVICECONTROL status word (word 0) and ERRNUM parameter <<02556>>22478000
      (word 1). They overlay (words 0 and 1 of) our appendage, <<02556>>22480000
      that is, our message array and are available  after  the <<02556>>22482000
      second call to MANAGEWRITECONVERSATION.                  <<02556>>22484000
  c)  The one-word result of MANAGEWRITECONVERSATION, which is <<02556>>22486000
      discarded for both calls.                                <<02556>>22488000
;                                                              <<02556>>22490000
      LOCAL'FAILURE := GET'ERROR;   << Past sins hurt now.  >> <<02556>>22492000
      IF LOCAL'FAILURE <> 0 THEN TCOUNT := 0;                  <<02556>>22494000
                                                               <<02556>>22496000
      SETRFAPTR;     << Build message array on TOS.         >> <<02556>>22498000
      RFALEN := 8;   << Length of message array (appendage) >> <<02556>>22500000
      TOS := "RFA ";                                           <<02556>>22502000
      TOS := %65;    << FDEVCTRL DS code = intrinsic number >> <<02556>>22504000
      LOAD'ERROR;    << Add LOCAL'FAILURE in left byte.     >> <<02556>>22506000
      TOS := RFAFILE;                                          <<02556>>22508000
      TOS := TCOUNT;                                           <<02556>>22510000
      TOS := CTRL;                                             <<02556>>22512000
      TOS := P1;                                               <<02556>>22514000
      TOS := P2;                                               <<02556>>22516000
      GETMWCPARMS;   << Stack MANAGEWRITE... boilerplate.   >> <<02556>>22518000
      TOS := 0D;     << TARGET, TCOUNT omitted first time.  >> <<02556>>22520000
      TOS := 0D;     << Parameters of received    data.     >> <<02556>>22522000
      TOS := MWCPLABEL;                                        <<02556>>22524000
      ASSEMBLE (PCAL 0);   << Never thought we'd get here!  >> <<02556>>22526000
      DEL;                 << Don't need transfer length.   >> <<02556>>22528000
      CHECKXFER;   << Checks for DS err, not FDEVCTRL error >> <<02556>>22530000
      IF LOCAL'FAILURE = 0 THEN                                <<02556>>22532000
         BEGIN   << O.K. to do second MWC call.                <<02556>>22534000
         RFALEN := 0;   << No appendage required this time. >> <<02556>>22536000
         GETMWCPARMS;   << Stack MWC boilerplate again.     >> <<02556>>22538000
         TOS := @TARGET;   << Send TARGET, TCOUNT this time >> <<02556>>22540000
         TOS := TCOUNT;                                        <<02556>>22542000
         TOS := 0D;        << No data coming back.          >> <<02556>>22544000
         TOS := MWCPLABEL;                                     <<02556>>22546000
         ASSEMBLE (PCAL 0);                                    <<02556>>22548000
         DEL;                                                  <<02556>>22550000
         CHECKXFER;                                            <<02556>>22552000
         RFALEN := 8;   << Leave it like we found it.       >> <<02556>>22554000
         END;           << of second MWC call.              >> <<02556>>22556000
                                                               <<02556>>22558000
<< The following kludge is here only to  make  DELAPPENDAGE >> <<02556>>22560000
<< work but leave two words on the stack. It usually leaves >> <<02556>>22562000
<< only one.                                                >> <<02556>>22564000
                                                               <<02556>>22566000
      RFALEN := RFALEN - 1;                                    <<02556>>22568000
      DELAPPENDAGE;   << Cut back stack to status, errnum.  >> <<02556>>22570000
      ASSEMBLE (XCH);                                          <<02556>>22572000
      ERRNUM := S1;   << This is remote FDEVCTRL ERRNUM.    >> <<02556>>22574000
      TOS := TOS.CC;  << And this is remote FDEVCTRL CC.    >> <<02556>>22576000
      END;    << 1 -- remote file.                          >> <<02556>>22578000
                                                               <<02556>>22580000
    END;   << CASE statement.                               >> <<02556>>22582000
                                                               <<02556>>22584000
EXIT:                                                                   22586000
   CONDCODE := TOS;                                            <<02556>>22588000
   RESETCRITICAL(CRIT);                                                 22590000
   ERROREXIT (INTRINEXIT, S0, 0);                              <<02556>>22592000
   END;                                                                 22594000
$PAGE " FSETMODE "                                                      22596000
$CONTROL SEGMENT = FILESYS2   << FSETMODE >>                            22598000
PROCEDURE FSETMODE(FN,FLAGS);                                           22600000
   << Used to change access mode flags for the specified file.          22602000
                                                                        22604000
     Input variables:                                                   22606000
         FN - file number                                               22608000
         FLAGS - new access modes                                       22610000
            BIT 12 - report tape error recovery                         22612000
            BIT 13 - inhibit terminal CR/LF (line control)              22614000
            BIT 14 - critical output verification                       22616000
                                                                        22618000
     Condition code:                                                    22620000
         CCE - request granted                                          22622000
         CCL - request denied because of error.                         22624000
                                                                        22626000
     All modes must be re-specified on each call.   >>                  22628000
VALUE FN,FLAGS;                                                         22630000
INTEGER FN;                                                             22632000
LOGICAL FLAGS;                                                          22634000
OPTION PRIVILEGED;                                                      22636000
   BEGIN                                                                22638000
   INTEGER CRIT;        << for SETCRITICAL >>                           22640000
                                                                        22642000
   << Remote file access (RFA) variables: >>                            22644000
                                                                        22646000
   INTEGER POINTER RFAPTR;    << appendage pointer >>                   22648000
   INTEGER RFALEN;            << appendage length >>                    22650000
                                                                        22652000
<< Following LOC'ACB params must be in order: >>                        22654000
   INTEGER AFTE;       << AFT entry word 0 >>                           22656000
   INTEGER PACBV;                                                       22658000
   INTEGER LACBV;                                                       22660000
   INTEGER IOQX;                                                        22662000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+8 >>                    22664000
   INTEGER ACB'ERROR    = ACB+14;                                       22666000
                                                                        22668000
   INTEGER DSTX;       << User's DB setting - must be last >>           22670000
                                                                        22672000
$  IF X0 = ON                                                           22674000
   IF MONCALLABLE THEN                                                  22676000
      BEGIN       << monitoring >>                                      22678000
      FTITLE("FSET","MODE",0D,0D);                                      22680000
      DEBUG                                                             22682000
      END;                                                              22684000
$  IF                                                                   22686000
                                                                        22688000
   ERRORON;                                                             22690000
   CRIT := SETCRITICAL;                                                 22692000
   LOC'ACB(*,8,FN,UMODE);    << get ACB >>                              22694000
   IF < THEN                                                            22696000
      BEGIN          << Invalid file number >>                          22698000
      TOS := INVFN;  << error nr. >>                                    22700000
      TOS := CCL;    << error condition code >>                         22702000
      GO EXIT                                                           22704000
      END;                                                              22706000
   IF > THEN                                                            22708000
      BEGIN         << File is $NULL >>                                 22710000
      TOS := 0;    << No error >>                                       22712000
      TOS := CCE;  << OK condition code >>                              22714000
      GO EXIT                                                           22716000
      END;                                                              22718000
   CASE * FTYPE OF                                                      22720000
   BEGIN                                                                22722000
                                                                        22724000
   BEGIN     << Conventional file >>                                    22726000
   IF IOQX <> 0 THEN                                                    22728000
      BEGIN       << No-wait I/O pending. >>                            22730000
      TOS := IOPENDING;                                                 22732000
      ACB'ERROR := S0;  << error nr. >>                                 22734000
      TOS := CCL;     << error condition code >>                        22736000
      GO UNLK                                                           22738000
      END;                                                              22740000
   ACBMODE := FLAGS;  << Update the mode >>                             22742000
   ACB'ERROR := 0;                                                      22744000
                                                                        22746000
   <<* * * Measurement data on FSETMODE ** * *>>                        22748000
                                                                        22750000
$  IF X3 = ON                                                           22752000
   IF MEAS'TAPE'ON THEN BEGIN                                           22754000
   IF ACBACCCL = DIRACC THEN                                            22756000
      MMSTAT(EFSETMODE,FN,FLAGS,0);                                     22758000
   END;    << of MEAS'TAPE'ON>>                                         22760000
$  IF                                                                   22762000
                                                                        22764000
   TOS := 0;    << no error >>                                          22766000
   TOS := CCE;  << OK condition code >>                                 22768000
UNLK:                                                                   22770000
   UNLOC'ACB(8,0);       << release ACB >>                              22772000
   END;      << conventional file >>                                    22774000
                                                                        22776000
   BEGIN    << Remote file >>                                           22778000
   SETRFAPTR;                                                  <<DS.00>>22780000
   RFALEN := 5;                                                <<DS.00>>22782000
   TOS := "RFA ";                                              <<DS.00>>22784000
   TOS := 16;                                                  <<DS.00>>22786000
   TOS := RFAFILE;                                             <<DS.00>>22788000
   TOS := FLAGS;                                               <<DS.00>>22790000
   MWCNOBUF;                                                   <<DS.00>>22792000
   CHECKXFER;                                                  <<DS.00>>22794000
   DELAPPENDAGE;                                               <<DS.00>>22796000
   PREPRETURN;                                                 <<DS.00>>22798000
   END;     << Remote file >>                                           22800000
                                                                        22802000
      << dummy 2 >>;                                                    22804000
      << dummy 3 >>;                                                    22806000
      << dummy 4 >>;                                                    22808000
      << dummy 5 >>;                                                    22810000
   BEGIN   << KSAM file >>                                              22812000
   KSETMODE(FN,FLAGS);                                         <<KS.00>>22814000
   PUSH(STATUS);                                               <<KS.00>>22816000
   TOS := TOS.CC;    << report condition code >>               <<KS.00>>22818000
   ASMB(ZERO,XCH);                                             <<KS.00>>22820000
   END;  << KSAM file >>                                       <<KS.00>>22822000
   <<DUMMY>>;                                                  <<HM.00>>22824000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>22826000
   TOS:=0;                                                     <<HM.00>>22828000
   TOS:=CCE;                                                   <<HM.00>>22830000
   UNLOC'ACB(8,0);   <<RELEASE THE ACB>>                       <<HM.00>>22832000
   END;                                                        <<HM.00>>22834000
   END;       << FTYPE case >>                                          22836000
                                                                        22838000
EXIT:                                                                   22840000
   CONDCODE := TOS;  << Report condition code >>                        22842000
   RESETCRITICAL(CRIT);                                                 22844000
   ERROREXIT(2,S0,0)                                                    22846000
   END;          << procedure FSETMODE >>                               22848000
$PAGE " FRELATE "                                                       22850000
$CONTROL SEGMENT = FILESYS2   << FRELATE >>                             22852000
LOGICAL PROCEDURE FRELATE(FN1,FN2);                                     22854000
VALUE FN1,FN2;                                                          22856000
INTEGER FN1,FN2;                                                        22858000
OPTION PRIVILEGED;                                                      22860000
   BEGIN                                                                22862000
   INTEGER CRIT;       << for SETCRITICAL >>                            22864000
   INTEGER LD1;        << FN1's log. dev. nr.>>                         22866000
   INTEGER LD2;        << FN2's log. dev. nr.>>                         22868000
   INTEGER TEMP;      << Default output log. dev. nr. for LD1>>         22870000
   INTEGER POINTER PCBX;                                                22872000
<< Following LOC'ACB params must be in order: >>                        22874000
   INTEGER AFTE;                                                        22876000
   INTEGER PACBV;                                                       22878000
   INTEGER LACBV;                                                       22880000
   INTEGER IOQX;                                                        22882000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+10 >>                   22884000
   INTEGER DSTX;       << user's buffer DST >>                          22886000
   << End of LOC'ACB params >>                                          22888000
                                                                        22890000
   INTEGER SUBROUTINE LDN (FN);                                         22892000
      << Returns the logical device number from the ACB for the         22894000
         specified file number.                                         22896000
                                                                        22898000
        Input variables:                                                22900000
            FN - file number                                            22902000
                                                                        22904000
        Output variables:                                               22906000
            LDN - logical device number                                 22908000
                                                                        22910000
       Returns 0 for invalid files; exits the procedure with CCG if     22912000
       the file is $NULL.        >>                                     22914000
                                                                        22916000
   VALUE FN;                                                            22918000
   INTEGER FN;                                                          22920000
      BEGIN                                                             22922000
      LOC'ACB(0,10,FN,UMODE);                                           22924000
      DEL;      << don't need DSTX >>                                   22926000
      IF < THEN GO SXIT;    << invalid file nr. >>                      22928000
      IF > THEN                                                         22930000
         BEGIN       << File is $NULL >>                                22932000
         TOS := 0;   << no error >>                                     22934000
         TOS := CCG;                                                    22936000
         GO EXIT                                                        22938000
         END;                                                           22940000
      IF KSTYPE THEN                                           <<KS.00>>22942000
         BEGIN     << KSAM file >>                             <<KS.00>>22944000
         TOS := 0;                                             <<KS.00>>22946000
         TOS := CCE;                                           <<KS.00>>22948000
         FRELATE := 0;                                         <<KS.00>>22950000
         GO TO EXIT;      << done >>                           <<KS.00>>22952000
         END;    << KSAM file >>                               <<KS.00>>22954000
      IF RFTYPE THEN                                           <<DS.00>>22956000
         BEGIN                                                 <<DS.00>>22958000
         LDN := -1;                                            <<DS.00>>22960000
         RETURN;                                               <<DS.00>>22962000
         END;                                                  <<DS.00>>22964000
      LDN := ACBDADDR;   << Log. device nr. >>                          22966000
      UNLOC'ACB(10,0);    << release ACB >>                             22968000
SXIT: END;     << subroutine LDN >>                                     22970000
                                                                        22972000
$  IF X0 = ON                                                           22974000
   IF MONCALLABLE THEN                                                  22976000
      BEGIN                                                             22978000
      FTITLE("FREL","ATE ",0D,0D);                                      22980000
      DEBUG                                                             22982000
      END;                                                              22984000
$  IF                                                                   22986000
                                                                        22988000
   ERRORON;                                                             22990000
   CRIT := SETCRITICAL;                                                 22992000
   TOS := LDN(FN1);     << get FN1's log. dev. nr. >>                   22994000
   ASMB(TEST);                                                          22996000
   IF = THEN                                                            22998000
      BEGIN      << Invalid file nr. >>                                 23000000
INVAL:TOS := INVFN;                                                     23002000
      TOS := CCL;                                                       23004000
      GO EXIT;                                                          23006000
      HELP;  << dummy call >>                                  <<00117>>23008000
      END;                                                              23010000
   LD1 := TOS;    << File 1's log. dev. nr. >>                          23012000
   IF RFTYPE THEN TEMP := 0 ELSE                                        23014000
      BEGIN                                                             23016000
      TOS := EXCHANGEDB(LDT);  << Set DB to LDT >>                      23018000
      TEMP := ADB0(LD1*LDTENTRY+LDTNO).(8:8);  << default Output LDN >> 23020000
      ASMB(ZERO,XCH);     << for result of EXCHANGEDB >>                23022000
      EXCHANGEDB(*);      << Reset DB to orig. DST >>                   23024000
      END;                                                              23026000
   TOS := LDN(FN2);       << Get FN2's log. dev. nr. >>                 23028000
   ASMB(TEST);                                                          23030000
   IF = THEN GO INVAL;    << invalid file nr. >>                        23032000
   LD2 := TOS;                                                          23034000
                                                                        23036000
   TOS := EXCHANGEDB(0);  << set DB to stack >>                         23038000
   SETPCBX;           << init. PCBX pointer >>                          23040000
   IF LD1 = PXGSTDIN AND LD2 = PXGSTDLIST THEN                          23042000
      TOS := PCBX(6)&LSL(4)   << D,I in bits 0,1>>                      23044000
   ELSE IF LD2 = TEMP THEN    << Default output device? >>              23046000
      TOS := LPDT(LOGICAL(LD1)*LPDTENTRY + 1) & LSL(5)         <<04321>>23048000
   ELSE      << No relation >>                                          23050000
      TOS := 0;                                                         23052000
   FRELATE := TOS&ASR(14) LAND %100001;  <<D--------------I>>           23054000
   ASMB(ZERO,XCH);    << for result of EXCHANGEDB >>                    23056000
   EXCHANGEDB(*);     << Reset DB to orig. DST >>                       23058000
   TOS := 0;          << No error >>                                    23060000
   TOS := CCE;        << OK condition code >>                           23062000
                                                                        23064000
EXIT:                                                                   23066000
   CONDCODE := TOS;    << Report condition code >>                      23068000
   RESETCRITICAL(CRIT);                                                 23070000
   ERROREXIT(2,S0,0)                                                    23072000
   END;     << procedure FRELATE >>                                     23074000
$PAGE " FCHECK "                                                        23076000
$CONTROL SEGMENT = FILESYS3   << FCHECK >>                              23078000
PROCEDURE FCHECK(FILENUM,ERRORCODE,TLOG,BLKNUM,NUMRECS);                23080000
VALUE FILENUM;                                                          23082000
INTEGER FILENUM,ERRORCODE,TLOG,NUMRECS;                                 23084000
DOUBLE BLKNUM;                                                          23086000
OPTION VARIABLE,PRIVILEGED;                                             23088000
   BEGIN                                                                23090000
   LOGICAL PMAP = Q-4;   << parameter bit map >>                        23092000
   EQUATE UBND = -10; <<Q rel upper bound for bounds check>>   <<03059>>23094000
   INTEGER CRIT;         << for SETCRITICAL >>                          23096000
   INTEGER EC := 0;      << error nr. >>                                23098000
   INTEGER TL := 0;      << transmission log >>                         23100000
   INTEGER NR := 0;      << blocking factor >>                          23102000
   DOUBLE BN := 0D;      << block nr. >>                                23104000
   DOUBLE RN := 0D;      << record nr. >>                               23106000
   LOGICAL SPOOLED := FALSE;                                            23108000
   INTEGER ERR := 0;                                                    23110000
   INTEGER POINTER PXFILE;                                              23112000
                                                                        23114000
<< Remote file access (RFA) variables: >>                               23116000
                                                                        23118000
   INTEGER POINTER RFAPTR;  << appendage pointer >>                     23120000
   INTEGER RFALEN;          << appendage length >>                      23122000
                                                                        23124000
<< Following LOC'ACB params must be in order: >>                        23126000
   INTEGER AFTE;                                                        23128000
   INTEGER PACBV;                                                       23130000
   INTEGER LACBV;                                                       23132000
   INTEGER IOQX;                                                        23134000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+18 >>                   23136000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        23138000
   BUILD'ACB;                                                           23140000
   INTEGER ACB'TLOG     = ACB+15;                                       23142000
                                                                        23144000
   INTEGER DSTX;       << user's buffer DST >>                          23146000
   << End of LOC'ACB params >>                                          23148000
                                                                        23150000
$  IF X0 = ON                                                           23152000
   IF MONCALLABLE THEN                                                  23154000
      BEGIN                                                             23156000
      FTITLE("FCHE","CK  ",0D,0D);                                      23158000
      DEBUG                                                             23160000
      END;                                                              23162000
$  IF                                                                   23164000
                                                                        23166000
   ERRORON;                                                             23168000
   CRIT := SETCRITICAL;                                                 23170000
   TOS := PMAP;     << parameter bit map >>                             23172000
   IF NOT LS0.(11:1) OR (FILENUM = 0) THEN                              23174000
      BEGIN            << Return last error from FOPEN. >>              23176000
      DSTX := EXCHANGEDB(0);    << set DB to stack >>                   23178000
      SETPXFILE;          << init. PXFILE pointer >>                    23180000
      EC := PXFFOPEN;     << Last FOPEN error nr. >>                    23182000
      TOS := PXFKOPEN;                                         <<KS.00>>23184000
      EC.(0:8) := TOS;                                         <<KS.00>>23186000
      EXCHANGEDB(DSTX)  << Reset DB to user's DST >>                    23188000
      END                                                               23190000
   ELSE                                                                 23192000
      BEGIN       << Return last I/O error. >>                          23194000
      DEL;        << PMAP >>                                            23196000
      LOC'ACB(*,18,FILENUM,UMODE);                                      23198000
      IF < THEN                                                         23200000
         BEGIN      << Invalid file nr. >>                              23202000
         ERR := INVFN;                                                  23204000
         GO CCLEX                                                       23206000
         END;                                                           23208000
      IF > THEN GO NULLF;  <<$NULL?>>                                   23210000
      CASE * FTYPE OF                                                   23212000
      BEGIN                                                             23214000
                                                                        23216000
      BEGIN   << Conventional file >>                                   23218000
      BN:=ACBBTFRCT;                                           <<HM.00>>23220000
CONVENTIONAL:                                                  <<HM.00>>23222000
      EC := ACB'ERROR;                                                  23224000
      TL := ACB'TLOG;                                                   23226000
      NR := ACB'BLKFACT;                                                23228000
      RN := ACBRTFRCT;                                                  23230000
      SPOOLED := ACB'SPOOLED;    << for BLKNUM >>                       23232000
                                                                        23234000
      <<* * * Measurement data on FCHECK * * *>>                        23236000
                                                                        23238000
$     IF X3 = ON                                                        23240000
      IF MEAS'TAPE'ON THEN BEGIN                                        23242000
      IF ACB'ACCCL = DIRACC THEN                                        23244000
         MMSTAT(EFCHECK,FILENUM,EC,0);  <<MEASURE EVENT>>               23246000
      END; << OF MEAS'TAPE'ON>>                                         23248000
$     IF                                                                23250000
                                                                        23252000
      UNLOC'ACB(18,0);    << release ACB >>                             23254000
      END;      << conventional file >>                                 23256000
                                                               <<DS.00>>23258000
      BEGIN    << Remote file >>                               <<DS.00>>23260000
      SETRFAPTR;                                               <<DS.00>>23262000
      RFALEN := 5;                                             <<DS.00>>23264000
      TOS := "RFA ";                                           <<DS.00>>23266000
      TOS := 14;                                               <<DS.00>>23268000
      TOS := RFAFILE;                                          <<DS.00>>23270000
      TOS := PMAP;                                             <<DS.00>>23272000
      TOS := 0D;     << for FCHECK return >>                   <<DS.00>>23274000
      MWCNOBUF;                                                <<DS.00>>23276000
      IF <> THEN                                               <<DS.00>>23278000
         BEGIN                                                 <<DS.00>>23280000
         TOS := 0;                                             <<DS.00>>23282000
         TOS := RFALINE;                                       <<DS.00>>23284000
         TOS := DSCHKPLABEL;                                   <<DS.00>>23286000
         ASMB(PCAL 0);                                         <<DS.00>>23288000
         ERR := TOS;                                           <<DS.00>>23290000
$   IF X1 = ON                                                 <<DS.00>>23292000
         IF <> THEN FTROUBLE(486);                             <<KJ.03>>23294000
$   IF                                                         <<DS.00>>23296000
         GO CCLEX;                                             <<DS.00>>23298000
         END;                                                  <<DS.00>>23300000
      DEL; << MASK >>                                          <<DS.00>>23302000
      NR := TOS;                                               <<DS.00>>23304000
      BN := TOS;                                               <<DS.00>>23306000
      TL := TOS;                                               <<DS.00>>23308000
      EC := S0;                                                <<DS.00>>23310000
      ERR := TOS;                                              <<DS.00>>23312000
      IF TOS.CC = CCL THEN GO CCLEX;                           <<DS.00>>23314000
      END;     << remote file >>                                        23316000
         << dummy 2 >>;                                                 23318000
         << dummy 3 >>;                                                 23320000
         << dummy 4 >>;                                                 23322000
         << dummy 5 >>;                                                 23324000
      BEGIN    << KSAM file >>                                          23326000
      DSTX := EXCHANGEDB(0);  << Set DB to stack >>         <<KS.01.06>>23328000
      KCHECK(FILENUM,EC,TL,BN,NR);                             <<KS.00>>23330000
      PUSH(STATUS);                                            <<KS.00>>23332000
      EXCHANGEDB(DSTX);    << back to original DST >>       <<KS.01.06>>23334000
      IF TOS.CC = CCL THEN GO CCLEX;                           <<KS.00>>23336000
      END;    <<KSAM file >>                                   <<KS.00>>23338000
                                                               <<HM.00>>23340000
      <<DUMMY 7>>;                                             <<HM.00>>23342000
                                                               <<HM.00>>23344000
      BEGIN    <<MSG FILE>>                                    <<HM.00>>23346000
      BN:=IF ACBREAD THEN 0D ELSE ACBBLK;                      <<HM.00>>23348000
      GO CONVENTIONAL;                                         <<HM.00>>23350000
      END;                                                     <<HM.00>>23352000
                                                                        23354000
      END;     << FTYPE CASE >>                                         23356000
      END;     << return last I/O error >>                              23358000
                                                                        23360000
   <<* * * Return requested values * * *>>                              23362000
                                                                        23364000
NULLF:                                                                  23366000
   TOS := PMAP;    << Parameter bit map >>                              23368000
   IF LS0.(12:1) THEN                                                   23370000
      BEGIN       << Error nr. wanted >>                                23372000
      IF NOT FBNDCHK(@ERRORCODE,1,UBND) THEN GO BERR;          <<03059>>23374000
      IF KSTYPE THEN ERRORCODE := EC ELSE                      <<KS.00>>23376000
        ERRORCODE := EC.(8:8);                                          23378000
      END;                                                              23380000
   IF LS0.(13:1) THEN                                                   23382000
      BEGIN        << Transmission log wanted >>                        23384000
      IF NOT FBNDCHK(@TLOG,1,UBND) THEN GO BERR;               <<03059>>23386000
      TLOG := TL;                                                       23388000
      END;                                                              23390000
   IF LS0.(14:1) THEN                                                   23392000
      BEGIN        << Current block nr. wanted >>                       23394000
      IF NOT FBNDCHK(@BLKNUM,2,UBND) THEN GO BERR;             <<03059>>23396000
      BLKNUM := IF SPOOLED THEN RN ELSE BN;                             23398000
      END;                                                              23400000
   IF LS0.(15:1) THEN                                                   23402000
      BEGIN         << Blocking factor wanted >>                        23404000
      IF NOT FBNDCHK(@NUMRECS,1,UBND) THEN GO BERR;            <<03059>>23406000
      NUMRECS := NR;                                                    23408000
      END;                                                              23410000
   TOS := CCE;        << OK condition code >>                           23412000
   GO EXIT;                                                             23414000
                                                                        23416000
BERR:                                                                   23418000
   IF KSTYPE THEN FKSAMBNDVIOL(FILENUM);                       <<KS.00>>23420000
   ERR := BNDVIOL;                                                      23422000
                                                                        23424000
CCLEX:                                                                  23426000
   IF PMAP.(12:1) AND FBNDCHK(@ERRORCODE,1,UBND) THEN          <<03059>>23428000
      ERRORCODE := ERR;                                                 23430000
   TOS := CCL;   << Error condition code >>                             23432000
EXIT:                                                                   23434000
   CONDCODE := TOS;  << report condition code >>                        23436000
   RESETCRITICAL(CRIT);                                                 23438000
   ERROREXIT(6,ERR,0);                                                  23440000
   END;        << procedure FCHECK >>                                   23442000
$PAGE " FGETINFO "                                                      23444000
$CONTROL SEGMENT = FILESYS3   << FGETINFO >>                            23446000
PROCEDURE FGETINFO(FILENUM,FILENAME,FOPTIONS,AOPTIONS,                  23448000
   RECSIZE,                                                             23450000
   DEVTYPE,LDNUM,HDADDR,FILECODE,RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,  23452000
   BLKSIZE,EXTSIZE,NUMEXTENTS,USERLABELS,CREATORID,DISKADR);            23454000
<< Must be called with DB set to the stack. >>                          23456000
VALUE FILENUM;                                                          23458000
INTEGER FILENUM,RECSIZE,DEVTYPE,FILECODE,BLKSIZE,NUMEXTENTS,            23460000
   USERLABELS;                                                          23462000
BYTE ARRAY FILENAME,CREATORID;                                          23464000
LOGICAL FOPTIONS,AOPTIONS,LDNUM,HDADDR,EXTSIZE;                         23466000
DOUBLE RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,DISKADR;                    23468000
OPTION VARIABLE,PRIVILEGED;                                             23470000
   BEGIN                                                                23472000
   LOGICAL PMAP1 = Q-5;  << First parameter bit map >>                  23474000
   LOGICAL PMAP2 = Q-4;  << Second parameter bit map >>                 23476000
   EQUATE UBND = -26; << Q rel upper bound for bounds check>>  <<03059>>23478000
   INTEGER CRIT;         << for SETCRITICAL >>                          23480000
   INTEGER ERRS := 0;    << error nr. >>                                23482000
   BYTE POINTER BP1,BP2;                                                23484000
   LOGICAL ASC;                                                         23486000
   DOUBLE NM1,NM2;       << file name >>                                23488000
   LOGICAL FOREIGN := FALSE;                                   <<01115>>23490000
   LOGICAL MEASURE := FALSE;     << MMSTAT measurement? >>              23492000
                                                                        23494000
                                                                        23496000
   << Local copies of requested parameters >>                           23498000
                                                                        23500000
   LOGICAL FOPT := 0;      << FOPTIONS >>                               23502000
   LOGICAL AOPT := 0;      << AOPTIONS >>                               23504000
   INTEGER RECSI := 0;     << record size >>                            23506000
   LOGICAL DEVT := 0;      << device type and subtype >>                23508000
   LOGICAL LDN := 0;       << logical device nr. >>                     23510000
   INTEGER FC := 0;        << File code >>                              23512000
   DOUBLE RPTR := 0D;      << record pointer >>                         23514000
   DOUBLE ENDF := 0D;      << EOF record nr. >>                         23516000
   DOUBLE FL := 0D;        << file limit record nr. >>                  23518000
   DOUBLE LCT := 0D;       << record transfer count >>                  23520000
   DOUBLE PCT := 0D;       << block transfer count >>                   23522000
   INTEGER BLKSI := 0;     << block size >>                             23524000
   INTEGER EXTSI := 0;     << extent size >>                            23526000
   INTEGER NE := 0;        << number of extents >>                      23528000
   INTEGER UL := 0;        << nr. user labels >>                        23530000
   INTEGER DRTU := 0;      << device nr. & unit >>                      23532000
                                                                        23534000
<< Following LOC'ACB params must be in order: >>                        23536000
EQUATE ACBMQ = 37;                                             <<01672>>23538000
   INTEGER AFTE;                                                        23540000
   INTEGER PACBV;                                                       23542000
   INTEGER LACBV;                                                       23544000
   INTEGER IOQX;                                                        23546000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+37 >>                   23548000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        23550000
   BUILD'ACB;                                                           23552000
                                                                        23554000
   INTEGER DSTX;       << user's buffer DST >>                          23556000
   << End of LOC'ACB params >>                                          23558000
                                                                        23560000
   << FCB parameters >>                                                 23562000
                                                                        23564000
   LOGICAL FCBINFO := FALSE;  << FCB info read flag >>                  23566000
   LOGICAL NOFCB := FALSE;    << FCB exists >>                          23568000
   INTEGER ARRAY FCB(0:SIZEBFCB+2-1);  << FCB buffer >>                 23570000
   DOUBLE ARRAY FCBDBL(*) = FCB;                                        23572000
                                                                        23574000
   << File Label parameters >>                                          23576000
                                                                        23578000
   LOGICAL LABINFO := FALSE;  << File Label read flag >>                23580000
   DOUBLE LABADDR := 0D;      << file label sector address >>           23582000
   INTEGER P1 = LABADDR;      << first half >>                          23584000
   INTEGER POINTER FLAB;      << label buffer pointer >>                23586000
                                                               <<HM.00>>23588000
   <<MESSAGE FILE DECLARATIONS >>                              <<HM.00>>23590000
                                                               <<HM.00>>23592000
   LOGICAL MSGFILE:=FALSE;                                     <<HM.00>>23594000
   INTEGER MSGRECSIZE;                                         <<HM.00>>23596000
   DOUBLE  MSGEOF;                                             <<HM.00>>23598000
                                                                        23600000
   << Remote file access (RFA) variables: >>                            23602000
                                                                        23604000
   INTEGER POINTER RFAPTR;  << appendage pointer >>                     23606000
   INTEGER RFALEN;          << appendage length >>                      23608000
   ARRAY TOP(*)=FILENUM;    << for KSAM >>                              23610000
   ARRAY DUMMY(0:21);    <<for KSAM-must be last declaration >>         23612000
                                                                        23614000
   SUBROUTINE GETFCBINFO;                                               23616000
    << Initializes local variables with information from the            23618000
     FCB if the FCB has not already been read (FCBINFO=FALSE),          23620000
     otherwise does nothing.  DB must be at the stack.  >>              23622000
      BEGIN                                                             23624000
      IF (FSTYPE OR MSGFILE) AND NOT FCBINFO AND NOT NOFCB THEN<<HM.00>>23626000
         BEGIN                                                          23628000
         LOCK'CB(0,0,@FCB-@Q0,ACB'FCB.DSTN,ACB'FCB VTA);                23630000
         TOS := SIZEBFCB+2;    << word count >>                         23632000
         MOVE'DS'6;            << FCB + first e-map entry >>            23634000
         X := FCB.(2:14);      << FCB size >>                           23636000
         IF BADFCBSIZE THEN FTROUBLE(62);                               23638000
         NE := FCBNUMEXTS+1;                                            23640000
         EXTSI := FCBEXTSIZE;                                           23642000
         TOS := FCBLABEL;      << LDEV and sector nr. >>                23644000
         BS1 := 0;             << clear LDEV >>                         23646000
         LABADDR := TOS;       << file label sector nr. >>              23648000
         UL := FCBLBL;                                                  23650000
         FL := FCBFLIM;                                                 23652000
         ENDF := FCBEOF;                                                23654000
         UNLOCK'CB(0,ACB'FCB.DSTN,ACB'FCB VTA);                         23656000
         FCBINFO := TRUE     << set flag >>                             23658000
         END                                                            23660000
      END;                                                              23662000
                                                                        23664000
   SUBROUTINE RDLABEL;                                                  23666000
    << Reads the file label into the local buffer and sets the          23668000
     File Label flag (LABINFO).  >>                                     23670000
      BEGIN                                                             23672000
      IF NOT LABINFO THEN                                               23674000
         BEGIN             << File label not read yet >>                23676000
         X := TOS;         << save return address >>                    23678000
         ALLOCFLAB;        << allocate label buffer >>                  23680000
         TOS := X;         << restore return address >>                 23682000
         GETFCBINFO;       << Get file label address >>                 23684000
         TOS := FISIR;                                                  23686000
         TOS := GETSIR(FISIR);  << get File SIR >>                      23688000
         X := FLABIO(LDN,LABADDR,0,FLAB);  << read label >>             23690000
         RELSIR(*,*);         << Release File SIR >>                    23692000
         ASMB(LDXA,DEL);      << set CC on X >>                         23694000
         IF <> THEN                                                     23696000
            BEGIN     << Error. >>                                      23698000
            FLABIOERR(X,FILENUM);  << handle error >>                   23700000
            TOS := LBLIOERR;                                            23702000
            GO ERR                                                      23704000
            END;                                                        23706000
         LABINFO := TRUE    << set flag >>                              23708000
         END                                                            23710000
      END;                                                              23712000
                                                                        23714000
$  IF X0 = ON                                                           23716000
   IF MONCALLABLE THEN                                                  23718000
      BEGIN                                                             23720000
      FTITLE("FGET","INFO",0D,0D);                                      23722000
      DEBUG                                                             23724000
      END;                                                              23726000
$  IF                                                                   23728000
                                                                        23730000
   ERRORON;                                                             23732000
   CRIT := SETCRITICAL;                                                 23734000
   IF FILENUM < 1  << Make sure we can be legal >>             <<04144>>23736000
      THEN BEGIN                                               <<04144>>23738000
      TOS := INVFN; << Invalid file # >>                       <<04144>>23740000
      GO ERR;                                                  <<04144>>23742000
      END;                                                     <<04144>>23744000
   LOC'ACB(0,ACBMQ,FILENUM,UMODE);                             <<01672>>23746000
   DSTX := TOS;                                                         23748000
   IF < THEN                                                            23750000
      BEGIN        << Invalid file nr. >>                               23752000
      TOS := INVFN;                                                     23754000
      GO ERR                                                            23756000
      END;                                                              23758000
   IF > THEN                                                            23760000
      BEGIN      << file is $NULL >>                                    23762000
      FOPT.FOPDESIGNATORF := 6;    << make $NULL >>                     23764000
      NM1 := "$NUL"; NM2 := "L   ";                            <<00899>>23766000
      AOPT := 4;                                                        23768000
      NOFCB := TRUE;                                                    23770000
      GO RETVAL                                                         23772000
      END;                                                              23774000
   IF DSTX <> 0 THEN                                                    23776000
      BEGIN     << Split-stack mode - illegal. >>                       23778000
      TOS := ILLDB;                                                     23780000
      IF FSTYPE OR MSGFILE THEN                                <<01624>>23782000
         BEGIN   << Log FSERR in ACB and unlock it.         >> <<01624>>23784000
         ACB'ERROR := S0;                                      <<01624>>23786000
         UNLOC'ACB(ACBMQ,0);     << release ACB >>             <<01672>>23788000
         END;                                                  <<01624>>23790000
      GO ERR                                                            23792000
      END;                                                              23794000
   CASE * FTYPE OF                                                      23796000
   BEGIN                                                       <<DS.00>>23798000
                                                                        23800000
   BEGIN     << conventional file >>                                    23802000
                                                                        23804000
<<* * * Get data from ACB * * *>>                                       23806000
                                                                        23808000
CONVENTIONAL:                                                  <<HM.00>>23810000
   IF ACB'SPOOLED THEN                                                  23812000
      BEGIN           << Spoofle. >>                                    23814000
      FOPT  := ACBSPFOPT;                                               23816000
      IF FOPT.FOPDESIGNATORF = 4 THEN   << spooled input >>    <<01155>>23818000
         IF ACB'LSTATE.READMODE = STDINXRD <<$STDINX device>>  <<01155>>23820000
          THEN FOPT.FOPDESIGNATORF := 5;                       <<01155>>23822000
      AOPT  := ACBSPAOPT LAND %177357;                                  23824000
      LDN   := ACBSPVDEV;                                               23826000
      RECSI := -ACBSPREC;       << make -bytes >>                       23828000
      DEVT  := ACBSPTYPE;                                               23830000
                                                               <<04161>>23832000
      TOS := DEVT;      << Get ready to include the stype >>   <<04161>>23834000
      TOS.(0:8) := LPDT(LDN*LPDTENTRY+1).(12:4);               <<04161>>23836000
      DEVT := TOS;      << Subtype/Type >>                     <<04161>>23838000
                                                               <<04161>>23840000
      IF FOPT.FOPCONTROLF THEN RECSI := RECSI-1;                        23842000
      BLKSI := (RECSI-1)&ASR(1)&ASL(1);    << even bytes >>             23844000
      RPTR  := ACB'FPTR;                                                23846000
      LCT   := ACBRTFRCT;                                               23848000
      PCT   := LCT;                                                     23850000
      NOFCB := TRUE;                                                    23852000
      END                                                               23854000
   ELSE                                                                 23856000
      BEGIN         << Not spoofle >>                                   23858000
      FOPT := ACB'FOPTIONS;                                             23860000
      AOPT := ACB'AOPTIONS;                                             23862000
      LDN := ACB'DADDR;                                                 23864000
      DEVT := ACB'DTYPE;                                                23866000
      FOREIGN := IF DEVT=FDISC THEN TRUE ELSE FALSE;                    23868000
      TOS := DEVT;       << device type >>                              23870000
      TOS.(0:8) := LPDT(LDN*LPDTENTRY+1).(12:4);  <<subtype>>           23872000
      DEVT := TOS;     << device type and subtype >>                    23874000
      NOFCB:=((DEVT LAND %70)<>DIRACC) LOR FOREIGN;            <<01115>>23876000
      DRTU := LDEVTODRT(LDN);                                  <<03052>>23878000
      ASC := FOPT.FOPASCIIF;                                            23880000
      IF MSGFILE THEN                                          <<HM.00>>23882000
         TOS:=MSGRECSIZE                                       <<HM.00>>23884000
      ELSE                                                     <<HM.00>>23886000
         BEGIN                                                 <<HM.00>>23888000
         TOS := ACBRSIZE;                                      <<HM.00>>23890000
         IF ACB'VARIABLE AND NOT ACB'MSGFILE THEN TOS:=TOS-4;  <<01750>>23892000
         IF ACB'SPECVAR THEN TOS := TOS-8;                     <<HM.00>>23894000
         END;                                                  <<HM.00>>23896000
      IF ASC THEN TOS := -TOS ELSE TOS := (TOS+1)&LSR(1);               23898000
      RECSI := TOS;        << -bytes or +words >>                       23900000
      IF NOT ACB'RIO OR ACB'INHIBITBUF THEN                    <<00630>>23902000
         BEGIN      << Total block size >>                     <<00630>>23904000
         TOS := ACBBSIZE;                                      <<00630>>23906000
         END                                                   <<00630>>23908000
      ELSE                                                     <<00630>>23910000
         BEGIN   << Data block size only (assume non-var.) >>  <<00630>>23912000
         TOS:=(ACBRSIZE+1)/2 * ACB'BLKFACT;                    <<00630>>23914000
         END;                                                  <<00630>>23916000
      IF ASC THEN TOS := -(TOS&LSL(1));    << make -chars >>            23918000
      BLKSI := TOS;                                                     23920000
      IF MSGFILE THEN                                          <<HM.00>>23922000
         BEGIN                                                 <<HM.00>>23924000
         RPTR:=IF ACBREAD THEN 0D ELSE MSGEOF;                 <<HM.00>>23926000
         END                                                   <<HM.00>>23928000
      ELSE                                                     <<HM.00>>23930000
         RPTR:=ACB'FPTR;                                       <<HM.00>>23932000
      LCT := ACBRTFRCT;                                                 23934000
      PCT := ACBBTFRCT;                                                 23936000
      GETFCBINFO;                                              <<HM.00>>23938000
      END;                                                              23940000
   NM1 := ACBNAME1;     << file name - first half >>                    23942000
   NM2 := ACBNAME2;     << file name - second half >>                   23944000
                                                                        23946000
$  IF X3 = ON                                                           23948000
   IF ACB'ACCCL = DIRACC THEN MEASURE := TRUE;                          23950000
$  IF                                                                   23952000
                                                                        23954000
   UNLOC'ACB(ACBMQ,0);       << release ACB >>                 <<01672>>23956000
   END;    << conventional file >>                                      23958000
                                                                        23960000
   BEGIN    << Remote file >>                                           23962000
   ALLOCRFABUF;                                                <<DS.00>>23964000
   RFALEN := 6;                                                <<DS.00>>23966000
   TOS := "RFA ";                                              <<DS.00>>23968000
   TOS := 13;                                                  <<DS.00>>23970000
   TOS := RFAFILE;                                             <<DS.00>>23972000
   TOS := PMAP1;                                               <<DS.00>>23974000
   TOS := PMAP2;                                               <<DS.00>>23976000
   ASMB(ADDS 38);    << for returned data >>                   <<DS.00>>23978000
   MWCNOBUF;                                                   <<DS.00>>23980000
   IF <> THEN                                                  <<DS.00>>23982000
      BEGIN                                                    <<DS.00>>23984000
      TOS := 0;                                                <<DS.00>>23986000
      TOS := RFALINE;                                          <<DS.00>>23988000
      TOS := DSCHKPLABEL;                                      <<DS.00>>23990000
      ASMB(PCAL 0);                                            <<DS.00>>23992000
$  IF X1 = ON                                                  <<DS.00>>23994000
      IF <> THEN FTROUBLE(486);                                <<KJ.03>>23996000
$  IF                                                          <<DS.00>>23998000
      GO ERR;                                                  <<DS.00>>24000000
      END;                                                     <<DS.00>>24002000
   IF RFAPTR.CC = CCL THEN                                     <<DS.00>>24004000
      BEGIN     << Remote failure >>                           <<DS.00>>24006000
      TOS := 0;                                                <<DS.00>>24008000
      GO TO ERR;                                               <<DS.00>>24010000
      END;                                                     <<DS.00>>24012000
   IF PMAP1.(13:1) THEN                                        <<DS.00>>24014000
      BEGIN     << File name wanted >>                         <<DS.00>>24016000
      IF NOT FBNDCHK(@FILENAME,-28,UBND) THEN GO BERR;         <<03059>>24018000
      TOS := @FILENAME;                                        <<DS.00>>24020000
      TOS := (@RFAPTR+1)&LSL(1);                               <<DS.00>>24022000
      MOVE * := *,(28);                                        <<DS.00>>24024000
      PMAP1.(13:1) := 0;                                       <<DS.00>>24026000
      END;                                                     <<DS.00>>24028000
   IF PMAP2.(14:1) THEN                                        <<DS.00>>24030000
      BEGIN    << Creator ID wanted >>                         <<DS.00>>24032000
      IF NOT FBNDCHK(@CREATORID,-8,UBND) THEN GO BERR;         <<03059>>24034000
      TOS := @CREATORID;                                       <<DS.00>>24036000
      TOS := (@RFAPTR+36)&LSL(1);                              <<DS.00>>24038000
      MOVE * := *,(8);                                         <<DS.00>>24040000
      PMAP2.(14:1) := 0;                                       <<DS.00>>24042000
      END;                                                     <<DS.00>>24044000
   DDEL; << PMAP'S >>                                          <<DS.00>>24046000
   TOS := PMAP2;                                               <<DS.00>>24048000
   IF TOS THEN                                                 <<DS.00>>24050000
      BEGIN    << Disk address wanted >>                       <<DS.00>>24052000
      IF NOT FBNDCHK(@DISKADR,1,UBND) THEN GO BERR;            <<03059>>24054000
      DISKADR := TOS;                                          <<DS.00>>24056000
      PMAP2.(15:1) := 0;                                       <<DS.00>>24058000
      END ELSE DDEL;                                           <<DS.00>>24060000
   ASMB(SUBS 4);   << creator ID >>                            <<DS.00>>24062000
   UL := TOS;                                                  <<DS.00>>24064000
   NE := TOS;                                                  <<DS.00>>24066000
   EXTSI := TOS;                                               <<DS.00>>24068000
   BLKSI := TOS;                                               <<DS.00>>24070000
   PCT := TOS;                                                 <<DS.00>>24072000
   LCT := TOS;                                                 <<DS.00>>24074000
   FL := TOS;                                                  <<DS.00>>24076000
   ENDF := TOS;                                                <<DS.00>>24078000
   RPTR := TOS;                                                <<DS.00>>24080000
   FC := TOS;                                                  <<DS.00>>24082000
   IF PMAP2.(3:1) THEN                                         <<DS.00>>24084000
      BEGIN    << return hardware address >>                   <<DS.00>>24086000
      IF NOT FBNDCHK(@HDADDR,2,UBND) THEN GO BERR;             <<03059>>24088000
      HDADDR := TOS;                                           <<DS.00>>24090000
      PMAP2.(3:1) := 0;                                        <<DS.00>>24092000
      END ELSE DEL;                                            <<DS.00>>24094000
   PUSH(DL);       << Get pointer to DSLINE's AFT entry >>     <<DS.06>>24096000
   TOS := TOS-4-RFALINE*AFTENTRY;                              <<DS.06>>24098000
   TOS := LPS0;      << logical dev# in right 8 bits >>        <<DS.06>>24100000
   LDN.(0:8) := TOS;                                           <<DS.06>>24102000
   DEL;              << pointer >>                             <<DS.06>>24104000
   LDN.(8:8) := TOS;   << Remote DEV# >>                       <<DS.06>>24106000
   DEVT := TOS;                                                <<DS.00>>24108000
   RECSI := TOS;                                               <<DS.00>>24110000
   AOPT := TOS;                                                <<DS.00>>24112000
   FOPT := TOS;                                                <<DS.00>>24114000
   ASMB(SUBS 15);    << delete name & status >>                <<DS.00>>24116000
   END;     << remote file >>                                           24118000
      << dummy 2 >>;                                                    24120000
      << dummy 3 >>;                                                    24122000
      << dummy 4 >>;                                                    24124000
      << dummy 5 >>;                                                    24126000
   BEGIN    << KSAM >>                                                  24128000
   MOVE DUMMY := TOP,(22);     << put param list on TOS >>     <<KS.00>>24130000
   ASMB(PCAL KGETINFO);                                        <<KS.00>>24132000
   PUSH(STATUS);     << Junk word to TOS.  CC unchanged >>     <<KS.00>>24134000
   IF <> THEN                                                  <<KS.00>>24136000
      GO TO ERR                                                <<KS.00>>24138000
   ELSE                                                        <<KS.00>>24140000
      BEGIN                                                    <<KS.00>>24142000
      CONDCODE := CCE;                                         <<KS.00>>24144000
      GO TO EXIT;                                              <<KS.00>>24146000
      END;                                                     <<KS.00>>24148000
   END;     << KSAM >>                                         <<KS.00>>24150000
   <<DUMMY 7>>;                                                <<HM.00>>24152000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>24154000
   MSGFILE:=TRUE;                                              <<HM.00>>24156000
   TOS := FCRETURNINFO(0,ACBMQ);                               <<01689>>24158000
   MSGRECSIZE:=TOS; MSGEOF:=TOS;                               <<HM.00>>24160000
   GO CONVENTIONAL;                                            <<HM.00>>24162000
   END;                                                        <<HM.00>>24164000
                                                                        24166000
   END;    << FTYPE CASE >>                                             24168000
                                                                        24170000
<<* * * Return requested values * * *>>                                 24172000
                                                                        24174000
RETVAL:                                                                 24176000
   TOS := PMAP1;     << First parameter bit map >>                      24178000
   IF NOT LS0.(12:1) THEN                                               24180000
      BEGIN         << No file number. Barf! >>                         24182000
      TOS := INVFN;                                                     24184000
      GO ERR                                                            24186000
      END;                                                              24188000
   IF LS0.(13:1) THEN                                                   24190000
      BEGIN          << File name requested >>                          24192000
      IF NOT FBNDCHK(@FILENAME,-28,UBND) THEN GO BERR;         <<03059>>24194000
      FILENAME := " ";                                                  24196000
      MOVE FILENAME(1) := FILENAME,(27);                                24198000
      @BP1 := @NM1&LSL(1);                                              24200000
      IF INTEGER(BP1) <> %40 THEN                                       24202000
         BEGIN                                                          24204000
         MOVE FILENAME := BP1,(8);                                      24206000
         END                                                            24210000
      ELSE                                                              24212000
         MOVE FILENAME := "....";                                       24214000
      IF NOT NOFCB THEN                                                 24216000
         BEGIN          << Disk file. >>                                24218000
         RDLABEL;                                                       24220000
         @BP1 := @FLLOCNAME&LSL(1);                                     24222000
         MOVE FILENAME := BP1,(8);                                      24224000
         SCAN FILENAME UNTIL " ",1;                                     24226000
         @BP2 := TOS;                                                   24228000
         BP2 := ".";                                                    24230000
         @BP1 := @FLGRPNAME&LSL(1);                                     24232000
         MOVE BP2(1) := BP1,(8);                                        24234000
         SCAN BP2 UNTIL " ",1;                                          24236000
         @BP2 := TOS;                                                   24238000
         BP2 := ".";                                                    24240000
         @BP1 := @FLACCTNAME&LSL(1);                                    24242000
         MOVE BP2(1) := BP1,(8);                                        24244000
         END;                                                           24246000
      END;        << file name requested >>                             24248000
   TOS := PMAP1;     << First parameter bit map >>                      24250000
   IF LS0.(14:1) THEN                                                   24252000
      BEGIN       << FOPTIONS wanted >>                                 24254000
      IF NOT FBNDCHK (@FOPTIONS,1,UBND) THEN GO BERR;          <<03059>>24256000
      FOPTIONS := FOPT;                                                 24258000
      END;                                                              24260000
   IF TOS THEN                                                          24262000
      BEGIN        << AOPTIONS wanted >>                                24264000
      IF NOT FBNDCHK (@AOPTIONS,1,UBND) THEN GO BERR;          <<03059>>24266000
      AOPTIONS := AOPT;                                                 24268000
      END;                                                              24270000
   TOS := PMAP2;   << Second parameter bit map >>                       24272000
   IF < THEN                                                            24274000
      BEGIN         << Record size wanted >>                            24276000
      IF NOT FBNDCHK (@RECSIZE,1,UBND) THEN GO BERR;           <<03059>>24278000
      RECSIZE := RECSI;                                                 24280000
      END;                                                              24282000
   IF LS0.(1:1) THEN                                                    24284000
      BEGIN         << Device type and subtype wanted >>                24286000
      IF NOT FBNDCHK(@DEVTYPE,1,UBND) THEN GO BERR;            <<03059>>24288000
      DEVTYPE := DEVT;    << device type and subtype >>                 24290000
      END;                                                              24292000
   IF LS0.(2:1) THEN                                                    24294000
      BEGIN          << Logical device nr. wanted >>                    24296000
      IF NOT FBNDCHK(@LDNUM,1,UBND) THEN GO BERR;              <<03059>>24298000
      LDNUM := LDN;                                                     24300000
      END;                                                              24302000
   IF LS0.(3:1) THEN                                                    24304000
      BEGIN       << DRT and unit wanted. >>                            24306000
      IF NOT FBNDCHK(@HDADDR,1,UBND) THEN GO BERR;             <<03059>>24308000
      IF DRTU.(7:1) <> 0 THEN   << Check if DRT # > 255 >>     <<03052>>24310000
         BEGIN                                                 <<03052>>24312000
         HDADDR.(8:8) := DRTU.(0:7);  << Deposit UNIT # >>     <<03052>>24314000
         IF FSTYPE OR MSGFILE THEN                             <<03052>>24316000
            BEGIN                                              <<03052>>24318000
            LOC'ACB(*,ACBMQ,FILENUM,UMODE);                    <<03052>>24320000
            ACB'ERROR := TOOBIGDRT;   << Insert error code >>  <<03052>>24322000
            UNLOC'ACB(ACBMQ,0);       << Release ACB >>        <<03052>>24324000
            END;                                               <<03052>>24326000
         GOTO ERR;                                             <<03052>>24328000
         END;                                                  <<03052>>24330000
      HDADDR := DRTU.(0:7);          << Deposit UNIT # >>      <<03052>>24332000
      HDADDR.(0:8) := DRTU.(8:8);    << Deposit DRT # >>       <<03052>>24334000
      END;                                                              24336000
   IF LS0.(4:1) THEN                                                    24338000
      BEGIN        << Filecode wanted. >>                               24340000
      IF NOT FBNDCHK(@FILECODE,1,UBND) THEN GO BERR;           <<03059>>24342000
      IF FSTYPE OR MSGFILE THEN                                <<HM.00>>24344000
        IF NOFCB THEN TOS := 0    << not officially a disk file >>      24346000
        ELSE                                                            24348000
         BEGIN     << A real disk file. >>                              24350000
         RDLABEL;  << Read file label >>                                24352000
         TOS := FLFILECODE                                              24354000
         END                                                   <<DS.00>>24356000
      ELSE IF RFTYPE THEN TOS := FC;                           <<DS.00>>24358000
      FILECODE := TOS;                                                  24360000
      END;                                                              24362000
   TOS := PMAP2;     << second parameter bit map >>                     24364000
   IF LS0.(5:1) THEN                                                    24366000
      BEGIN       << Record pointer wanted >>                           24368000
      IF NOT FBNDCHK(@RECPTR,2,UBND) THEN GO BERR;             <<03059>>24370000
      RECPTR := RPTR;                                                   24372000
      END;                                                              24374000
   IF LS0.(6:1) THEN                                                    24376000
      BEGIN       << EOF pointer wanted >>                              24378000
      IF NOT FBNDCHK(@EOF,2,UBND) THEN GO BERR;                <<03059>>24380000
      IF MSGFILE THEN                                          <<HM.00>>24382000
         EOF:=MSGEOF                                           <<HM.00>>24384000
      ELSE                                                     <<HM.00>>24386000
         BEGIN                                                 <<HM.00>>24388000
         GETFCBINFO;                                           <<HM.00>>24390000
         EOF := ENDF;                                          <<HM.00>>24392000
         END;                                                  <<HM.00>>24394000
      END;                                                              24396000
   IF LS0.(7:1) THEN                                                    24398000
      BEGIN        << file limit pointer wanted >>                      24400000
      IF NOT FBNDCHK(@FLIMIT,2,UBND) THEN GO BERR;             <<03059>>24402000
      IF FOREIGN THEN FLIMIT := DISCSIZE(LDN)                  <<01115>>24404000
        ELSE                                                   <<01115>>24406000
         BEGIN                                                 <<01115>>24408000
         GETFCBINFO;                                           <<01115>>24410000
         FLIMIT := FL;                                         <<01115>>24412000
         END;                                                  <<01115>>24414000
      END;                                                              24416000
   IF LS0.(8:1) THEN                                                    24418000
      BEGIN       << Record transfer count wanted. >>                   24420000
      IF NOT FBNDCHK(@LOGCOUNT,2,UBND) THEN GO BERR;           <<03059>>24422000
      LOGCOUNT := LCT;                                                  24424000
      END;                                                              24426000
   IF LS0.(9:1) THEN                                                    24428000
      BEGIN         << Block transfer count wanted. >>                  24430000
      IF NOT FBNDCHK(@PHYSCOUNT,2,UBND) THEN GO BERR;          <<03059>>24432000
      PHYSCOUNT := PCT;                                                 24434000
      END;                                                              24436000
   IF LS0.(10:1) THEN                                                   24438000
      BEGIN        << Block size wanted. >>                             24440000
      IF NOT FBNDCHK(@BLKSIZE,1,UBND) THEN GO BERR;            <<03059>>24442000
      BLKSIZE := BLKSI;                                                 24444000
      END;                                                              24446000
   IF LS0.(11:1) THEN                                                   24448000
      BEGIN        << Extent size wanted. >>                            24450000
      IF NOT FBNDCHK(@EXTSIZE,1,UBND) THEN GO BERR;            <<03059>>24452000
      GETFCBINFO;                                                       24454000
      EXTSIZE := EXTSI;                                                 24456000
      END;                                                              24458000
   IF LS0.(12:1) THEN                                                   24460000
      BEGIN       << Number of extents wanted. >>                       24462000
      IF NOT FBNDCHK(@NUMEXTENTS,1,UBND) THEN GO BERR;         <<03059>>24464000
      GETFCBINFO;                                                       24466000
      NUMEXTENTS := NE;                                                 24468000
      END;                                                              24470000
   IF LS0.(13:1) THEN                                                   24472000
      BEGIN      << Number of user labels wanted. >>                    24474000
      IF NOT FBNDCHK(@USERLABELS,1,UBND) THEN GO BERR;         <<03059>>24476000
      GETFCBINFO;                                                       24478000
      USERLABELS := UL;                                                 24480000
      END;                                                              24482000
   IF LS0.(14:1) THEN                                                   24484000
      BEGIN       << Creator I. D. wanted >>                            24486000
      IF NOT FBNDCHK(@CREATORID,-8,UBND) THEN GO BERR;         <<03059>>24488000
      CREATORID := " ";                                                 24490000
      MOVE CREATORID(1) := CREATORID,(7);                               24492000
      IF NOT NOFCB THEN                                                 24494000
         BEGIN          << Disk file. Get data from label >>            24496000
         RDLABEL;                                                       24498000
         TOS := @CREATORID; TOS := @FLUSERID&LSL(1);                    24500000
         MOVE * := *,(8)                                                24502000
         END;                                                           24504000
      END;                                                              24506000
   TOS := PMAP2;    << Second parameter bit map >>                      24508000
   IF TOS THEN                                                          24510000
      BEGIN       << File label address wanted. >>                      24512000
      IF NOT FBNDCHK(@DISKADR,1,UBND) THEN GO BERR;            <<03059>>24514000
      GETFCBINFO;                                                       24516000
      P1.(0:8) := LDN;                                                  24518000
      DISKADR := LABADDR;                                               24520000
      END;                                                              24522000
                                                                        24524000
   <<* * * Measurement data on FGETINFO * * *>>                         24526000
                                                                        24528000
$  IF X3 = ON                                                           24530000
   IF MEAS'TAPE'ON THEN BEGIN                                           24532000
   IF MEASURE THEN MMSTAT(EFGETINFO,FILENUM,PMAP1,PMAP2);               24534000
   END; << OF MEAS'TAPE'ON>>                                            24536000
$  IF                                                                   24538000
                                                                        24540000
   CONDCODE := CCE;                                                     24542000
   GO EXIT;                                                             24544000
                                                                        24546000
BERR:     << Bounds violation >>                                        24548000
   IF KSTYPE THEN FKSAMBNDVIOL(FILENUM);                       <<KS.00>>24550000
   IF FSTYPE OR MSGFILE THEN                                   <<HM.00>>24552000
      BEGIN                                                    <<HM.00>>24554000
      LOC'ACB(*,ACBMQ,FILENUM,UMODE);                          <<01672>>24556000
      ACB'ERROR := BNDVIOL;  << insert error nr. >>                     24558000
      UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<01672>>24560000
      END;                                                              24562000
                                                                        24564000
ERR:                                                                    24566000
   ERRS := TOS;    << Error nr. >>                                      24568000
   CONDCODE := CCL;                                                     24570000
                                                                        24572000
EXIT:                                                                   24574000
   RESETCRITICAL(CRIT);                                                 24576000
   ERROREXIT(22,ERRS,0)                                                 24578000
   END;           << procedure FGETINFO >>                              24580000
$PAGE " FGETPVINFO "                                                    24582000
$CONTROL SEGMENT = FILESYS3   << FGETPVINFO >>                          24584000
INTEGER PROCEDURE FGETPVINFO(FILENUM);                         <<00211>>24586000
VALUE FILENUM;  INTEGER FILENUM;                                        24588000
OPTION UNCALLABLE;                                                      24590000
   BEGIN                                                                24592000
   INTEGER CRIT;                                                        24594000
   LOGICAL DIRECTACCESS;                                                24596000
<< Following LOC'ACB params must be in order: >>                        24598000
   INTEGER AFTE;                                                        24600000
   INTEGER PACBV;                                                       24602000
   INTEGER LACBV;                                                       24604000
   INTEGER IOQX;                                                        24606000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+7 >>                    24608000
   INTEGER ACB'FCB      = ACB+26;                                       24610000
   INTEGER DSTX;       << user's buffer DST >>                          24612000
   << End of LOC'ACB params >>                                          24614000
                                                                        24616000
   CRIT := SETCRITICAL;                                                 24618000
   LOC'ACB(*,7,FILENUM,UMODE);                                          24620000
   IF < THEN                                                            24622000
      CONDCODE := CCL    << invalid FILENUM >>                          24624000
   ELSE IF = THEN                                                       24626000
      BEGIN      << Valid file number >>                                24628000
      IF FTYPE >= 1  AND  FTYPE <= 5 THEN                      <<04877>>24630000
         BEGIN          <<  Remote, DS, or CS >>               <<04877>>24632000
         FGETPVINFO := -1;                                     <<04877>>24634000
         CONDCODE := CCE;                                      <<04877>>24636000
         RESETCRITICAL(CRIT);                                  <<04877>>24638000
         RETURN;                                               <<04877>>24640000
         END;                                                  <<04877>>24642000
      CONDCODE := CCE;                                                  24644000
      DIRECTACCESS := (ACBACCCL=DIRACC) LAND (ACBDTYPE<>FDISC);         24646000
      IF DIRECTACCESS THEN                                              24648000
         BEGIN                                                          24650000
         TOS := GETFCB'INFO(ACB'FCB,9);                                 24652000
         DEL;      << extra half of double >>                           24654000
         FGETPVINFO := TOS;                                             24656000
         END;                                                           24658000
      UNLOC'ACB(7,0);                                                   24660000
      END ELSE CONDCODE := CCE;  << $NULL >>                            24662000
   RESETCRITICAL(CRIT);                                                 24664000
   END;      << procedure FGETPVINFO >>                                 24666000
$PAGE " FFILEINFO "                                                     24668000
$CONTROL SEGMENT=FILESYS3   << FFILEINFO >>                    <<00630>>24670000
                                                                        24672000
PROCEDURE FFILEINFO(FILENUM,ITEMNUM1,ITEMVAL1,                 <<00630>>24674000
                    ITEMNUM2,ITEMVAL2,ITEMNUM3,ITEMVAL3,                24676000
                    ITEMNUM4,ITEMVAL4,ITEMNUM5,ITEMVAL5);               24678000
VALUE FILENUM,ITEMNUM1,ITEMNUM2,ITEMNUM3,ITEMNUM4,ITEMNUM5;             24680000
INTEGER FILENUM,ITEMNUM1,ITEMNUM2,ITEMNUM3,ITEMNUM4,                    24682000
        ITEMNUM5;                                                       24684000
BYTE ARRAY ITEMVAL1,ITEMVAL2,ITEMVAL3,ITEMVAL4,ITEMVAL5;                24686000
OPTION VARIABLE,PRIVILEGED;                                             24688000
   BEGIN                                                                24690000
                                                                        24692000
   EQUATE                                                               24694000
      CALLSEQSIZE = 12,   << # words incl PARMMASK >>                   24696000
      FILEPARM = 10,     << LSR for "FILE" PARMMASK bit >>              24698000
      ITEM1PARM = 9;     << LSR for "ITEMNUM1" PARMMASK bit >>          24700000
   INTEGER ARRAY                                                        24702000
      PARM(*) = Q-5;                                                    24704000
   LOGICAL                                                              24708000
      PARMMASK = Q-4;                                          <<03059>>24710000
   EQUATE                                                      <<03059>>24712000
      UBND =   -16; << Q rel upper bound for user addresses>>  <<03059>>24714000
                                                                        24716000
   DEFINE                                                               24720000
      DEALLOCFLAB =                                                     24722000
         BEGIN                                                          24724000
         FLAB := 0;                                                     24726000
         MOVE FLAB(1) := FLAB,(127);                                    24728000
         ASSEMBLE(SUBS 128);                                            24730000
         END #;                                                         24732000
   DEFINE                                                               24734000
      STD'QINFOPTR =                                                    24736000
         BEGIN     << store Double from TOS >>                          24738000
         ASSEMBLE(XCH);                                                 24740000
         AQ0(QINFOPTR) := TOS;                                          24742000
         AQ0(X:=X+1) := TOS;                                            24744000
         END #;                                                         24746000
   DEFINE                                                      <<01115>>24748000
      FGIERR=                                                           24750000
         BEGIN                                                          24752000
         IF <> THEN                                                     24754000
            BEGIN                                                       24756000
            TOS := 0;  <<ignore error -- set by FGETINFO>>              24758000
            TOS := CCL;                                                 24760000
            GO EXIT;                                                    24762000
            END;                                                        24764000
         END#;                                                 <<01115>>24766000
   EQUATE                                                               24768000
      INFOSIZE = 6,     << INFODESC entry size >>              <<01864>>24770000
      NULLAOP = 4,      << for $NULL >>                                 24772000
      NULLFOP = %60;    << for $NULL >>                                 24774000
   DEFINE SPULAB'LAST'ENV = ULABEL(11)#;                                24778000
                                                                        24780000
   BYTE POINTER                                                         24782000
      ITEMVAL;                                                          24784000
   DOUBLE                                                               24786000
      FLABADDR := 0D,  << LDEV=0 ==> unknown addr >>                    24788000
      SECTOR;                                                           24790000
   INTEGER                                                              24792000
      CRIT,                                                             24794000
      I,                                                                24796000
      INFOLIMIT,     << LAST+1 index for INFODESC >>                    24798000
      ITEMNUM,                                                          24800000
      ITEMSIZE,                                                         24802000
      LDEV,                                                             24804000
      LDT'DENW,       << LDT entry density info, used for 46 >><<02560>>24806000
      LDT'DEVTYPE,    << dev type from LDT >>                  <<01115>>24808000
      LPDT'SUBTYPE,   << dev subtype from LPDT >>              <<01115>>24810000
      PINDEX,         << LSR/INDEX for PARMMASK/PARM>>                  24812000
      QINFODESC,      << Q-rel addr of INFODESC>>                       24814000
      QINFOINDEX,     << Q-rel index into INFODESC>>                    24816000
      QINFOLIMIT,     << Q-rel addr of INFODESC(INFOLIMIT)>>            24818000
      QINFOPTR,                                                         24820000
      TABLEITEM,                                                        24822000
      TABLENUM;                                                         24824000
                                                               <<01864>>24826000
COMMENT --                                                     <<01864>>24828000
  The following array, INFODESC, holds per-item data which is  <<01864>>24830000
used to retrieve the needed information from wherever it re-   <<01864>>24832000
sides, gather it in a local buffer INFO, then move it to       <<01864>>24834000
wherever the user wants it.                                    <<01864>>24836000
  An entry in INFODESC currently has six words.  Since all     <<01864>>24838000
references to entry size are through use of the equated length <<01864>>24840000
INFOSIZE (see below), it is quite easy to change the length of <<01864>>24842000
an entry.  A typical entry is shown below:                     <<01864>>24844000
                                                               <<01864>>24846000
   Entry-                                                      <<01864>>24848000
   relative                                                    <<01864>>24850000
   word      Identifier   Description                          <<01864>>24852000
   --------  ----------   -----------                          <<01864>>24854000
                                                               <<01864>>24856000
      0      TABLENUM     Arbitrarily assigned number of a     <<01864>>24858000
                          system table where the desired       <<01864>>24860000
                          information can be found.  See the   <<01864>>24862000
                          Equates in the Item Descriptor       <<01864>>24864000
                          Tables section.                      <<01864>>24866000
                                                               <<01864>>24868000
      1      TABLEITEM    Item within the TABLENUM table where <<01864>>24870000
                          the info actually lives.  New items  <<01864>>24872000
                          are assigned sequentially.           <<01864>>24874000
                                                               <<01864>>24876000
      2      QINFOPTR     See below.  Points to area of Info   <<01864>>24878000
                          where information retrieved from     <<01864>>24880000
                          TABLEITEM is placed before being     <<01864>>24882000
                          moved to caller's stack.             <<01864>>24884000
                                                               <<01864>>24886000
      3      @ITEMVAL     Ultimate destination of information  <<01864>>24888000
                          (in caller's stack) for this item.   <<01864>>24890000
                          A byte address.                      <<01864>>24892000
                                                               <<01864>>24894000
      4      ITEMSIZE     Length in bytes of the desired       <<01864>>24896000
                          information.  Defined further below. <<01864>>24898000
                                                               <<01864>>24900000
      5      ITEMNUM      The sequentially assigned number in  <<01864>>24902000
                          ITEMDESC, a table of all supported   <<01864>>24904000
                          FFILEINFO items.  Used when the      <<01864>>24906000
                          target file is remote.               <<01864>>24908000
                                                               <<01864>>24910000
Various  identifiers  starting  with  "[Q]INFO"  ("Q"  denotes <<01864>>24912000
Q-relative  versions  of the Q-less names) are associated with <<01864>>24914000
this array:                                                    <<01864>>24916000
                                                               <<01864>>24918000
  INFOSIZE     -- The length of each entry in INFODESC.  Since <<01864>>24920000
                  there are five entries (to  accommodate  the <<01864>>24922000
                  maximum  five  caller parameter pairs), this <<01864>>24924000
                  leads naturally to the INFODESC declaration. <<01864>>24926000
                                                               <<01864>>24928000
  QINFOINDEX   -- Pointer to the first word in the current en- <<01864>>24930000
                  try.                                         <<01864>>24932000
                                                               <<01864>>24934000
  [Q]INFOLIMIT -- Points to  next  available  INFODESC  entry, <<01864>>24936000
                  thereby  defining  the end of valid informa- <<01864>>24938000
                  tion in INFODESC.                            <<01864>>24940000
                                                               <<01864>>24942000
  QINFOPTR     -- Q-relative pointer to  INFO,  a  dynamically <<01864>>24944000
                  built  local  buffer which holds information <<01864>>24946000
                  retrieved from various locations in the sys- <<01864>>24948000
                  tem before it is moved to its final destina- <<01864>>24950000
                  tions in the user's stack.  QINFOPTR  serves <<01864>>24952000
                  two  purposes:   1) It points to the area of <<01864>>24954000
                  INFO where information for the current INFO- <<01864>>24956000
                  DESC entry is placed, and 2) it defines  the <<01864>>24958000
                  size of INFO after PREPROCESS finishes find- <<01864>>24960000
                  ing out what the (total) size is of all the  <<01864>>24962000
                  parameter items supplied by the user.        <<01864>>24964000
;                                                              <<01864>>24966000
   INTEGER ARRAY                                                        24968000
      INFODESC(0:INFOSIZE*5-1);                                         24970000
   INTEGER POINTER                                                      24972000
      FCB,                                                              24974000
      FLAB,                                                             24976000
      ULABEL=FLAB,                                                      24978000
      XDDEP,    << Spoolfile entry pointer >>                  <<00483>>24980000
      INFO;                                                             24982000
   LOGICAL                                                              24984000
      NOFCB,                                                            24986000
      NULLFILE := FALSE,                                                24988000
      SPOOLED;                                                          24990000
   DOUBLE POINTER                                                       24992000
      FCBDBL = FCB,                                                     24994000
      FLABDBL = FLAB;                                                   24996000
   INTEGER                                                              24998000
      ISECTOR = SECTOR;                                                 25000000
                                                                        25004000
                                                               <<01864>>25006000
<< Remote File Access (RFA) Variables.                      >> <<01864>>25008000
                                                               <<01864>>25010000
EQUATE                                                         <<01864>>25012000
  REMOTE'FILE = 1;  << FTYPE of remote file.                >> <<01864>>25014000
                                                               <<01864>>25016000
INTEGER POINTER                                                <<01864>>25018000
  RFAPTR;           << Message array (appendage) pointer.   >> <<01864>>25020000
                                                               <<01864>>25022000
INTEGER                                                        <<01864>>25024000
  RFA'BUF'LENGTH,   << Length of data to be returned by DS. >> <<01864>>25026000
  RFALEN,           << Length of appendage.                 >> <<01864>>25028000
  RFA'PARMMASK;     << Parameter mask to remote FFILEINFO.  >> <<01864>>25030000
                                                                        25032000
   << Following LOC'ACB params must be in order: >>                     25034000
EQUATE ACBMQ = 38;                                             <<02560>>25036000
   INTEGER AFTE;      << AFT entry word 0 >>                            25038000
   INTEGER PACBV;                                                       25040000
   INTEGER LACBV;                                                       25042000
   INTEGER IOQX;                                                        25044000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q + 38 >>        <<02560>>25046000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        25048000
   BUILD'ACB;                                                           25050000
   LOGICAL DSTX;     << DST nr. of caller's buffer >>                   25052000
   << end of LOC'ACB params >>                                          25054000
                                                                        25056000
                                                                        25058000
   <<******************************>>                                   25060000
   <<  Item Descriptor Tables      >>                                   25062000
   <<******************************>>                                   25064000
                                                                        25066000
   COMMENT:                                                             25068000
      When adding new item, must update the following:                  25070000
         MAXITEMNUM = last valid item number                            25072000
         ITEMDESC   = determines item size & system table.              25074000
      When adding new (system) table, must update following:            25076000
         MAXTABLENUM = last valid table number.                         25078000
      ;                                                                 25080000
                                                                        25082000
   EQUATE                                                               25084000
      DESCSIZE = 2,     << ITEMDESC entry size >>                       25086000
      MAXITEMNUM = 49,                                         <<03657>>25088000
      INTSIZE = 2,      << # bytes in integer >>                        25090000
      LOGSIZE = 2,      << # bytes in logical >>                        25092000
      DBLSIZE = 4;      << # bytes in double >>                         25094000
   EQUATE                                                               25096000
      ADHOCTABLE = 1,                                                   25098000
      ACBTABLE = 2,                                                     25100000
      FCBTABLE = 3,                                                     25102000
      FLABTABLE = 4,                                                    25104000
      TAPETABLE = 5,                                           <<01864>>25106000
      MAXTABLENUM=TAPETABLE;                                   <<01864>>25108000
   LOGICAL ARRAY                                                        25110000
      ACCESSTABLE(0:MAXTABLENUM);  << TRUE if table accessed >>         25112000
                                                                        25114000
   COMMENT:                                                             25116000
      "ITEMDESC" is indexed by ITEMNUM.  Entry format is:               25118000
         ITEMSIZE, [8/TABLENUM, 8/TABLEITEM]                            25120000
         ITEMSIZE  = # bytes in ITEM.  Used for bounds check on         25122000
                     ITEMVAL, so set to 0 if unknown or variable.       25124000
                                                                        25126000
         TABLENUM  = arbitrary number denoting sys table from           25128000
                     which item is retrieved.  Use "ADHOCTABLE"         25130000
                     (atble #0) if table unknown                        25132000
         TABLEITEM = corresponds to CASE-stmt index for table           25134000
                     retrieval.  TABLEITEM #0 of table #0 means         25136000
                     undefined item number.                             25138000
      Note that ITEMNUM #0 indicates a parameter which is to be         25140000
      ignored, just as if the ITEMNUM/VAL pair were missing.            25142000
      TABLENUM #0 must be mapped into another table number ...          25144000
      if mapped back to TABLENUM #0, this denotes an undefined          25146000
      item.                                                             25148000
      ;                                                                 25150000
                                                                        25152000
   EQUATE                                                               25154000
      ACBFOPITEM = 0,  <<item # in ACBTABLE>>                           25156000
      ACBAOPITEM = 1;  <<item # in ACBTABLE>>                           25158000
                                                                        25160000
   INTEGER ARRAY ITEMDESC(*) = PB :=                                    25162000
                                                                        25164000
              << FGETINFO items >>                                      25166000
                                                                        25168000
      <<000>> 0,       [8/0,          8/00], <<"missing">>              25170000
      <<001>> 28,      [8/ADHOCTABLE, 8/00], <<FNAME>>                  25172000
      <<002>> LOGSIZE, [8/ACBTABLE,   8/00], <<FOPS>>                   25174000
      <<003>> LOGSIZE, [8/ACBTABLE,   8/01], <<AOPS>>                   25176000
      <<004>> INTSIZE, [8/ADHOCTABLE, 8/01], <<RECSIZE>>                25178000
      <<005>> INTSIZE, [8/ADHOCTABLE, 8/02], <<DEVTYPE>>                25180000
      <<006>> LOGSIZE, [8/ACBTABLE,   8/02], <<LDEV>>                   25182000
      <<007>> LOGSIZE, [8/ADHOCTABLE, 8/03], <<UNIT,DRT>>               25184000
      <<008>> INTSIZE, [8/FLABTABLE,  8/03], << file code >>   <<00483>>25186000
      <<009>> DBLSIZE, [8/ACBTABLE,   8/03], <<RECPTR>>                 25188000
      <<010>> DBLSIZE, [8/FCBTABLE,   8/00], <<EOF>>                    25190000
      <<011>> DBLSIZE, [8/ADHOCTABLE, 8/06], <<FLIMIT>>        <<01864>>25192000
      <<012>> DBLSIZE, [8/ACBTABLE,   8/04], <<LOGCNT>>                 25194000
      <<013>> DBLSIZE, [8/ACBTABLE,   8/05], <<PHYCNT>>                 25196000
      <<014>> INTSIZE, [8/ADHOCTABLE, 8/05], <<BLKSIZE>>                25198000
      <<015>> LOGSIZE, [8/FCBTABLE,   8/02], <<EXTSIZE>>                25200000
      <<016>> INTSIZE, [8/FCBTABLE,   8/03], <<NUMEXT>>                 25202000
      <<017>> INTSIZE, [8/FCBTABLE,   8/04], <<ULABELS>>                25204000
      <<018>> 8,       [8/FLABTABLE,  8/00], <<CREATOR>>                25206000
      <<019>> DBLSIZE, [8/FCBTABLE,   8/05], <<LBLADDR>>                25208000
                                                                        25210000
              << Relative I/O >>                                        25212000
                                                                        25214000
      <<020>> INTSIZE, [8/ACBTABLE,   8/06], <<BLKFACT>>                25216000
      <<021>> INTSIZE, [8/ACBTABLE,   8/07], <<PHY BSIZE>>              25218000
      <<022>> INTSIZE, [8/ACBTABLE,   8/08], <<DATA BSIZE>>             25220000
      <<023>> INTSIZE, [8/ACBTABLE,   8/09], <<DATA OFFSET>>            25222000
      <<024>> INTSIZE, [8/ACBTABLE,   8/10], <<ART OFFSET>>             25224000
      <<025>> INTSIZE, [8/ACBTABLE,   8/11], <<ART SIZE>>               25226000
                                                                        25228000
              << Labeled tapes >>                                       25230000
                                                                        25232000
      <<026>> 6,       [8/TAPETABLE,  8/00], <<VOL ID>>        <<00828>>25234000
      <<027>> 6,       [8/TAPETABLE,  8/01], <<VOL SET ID>>    <<00828>>25236000
      <<028>> INTSIZE, [8/TAPETABLE,  8/02], <<EXP DATE>>      <<00828>>25238000
      <<029>> INTSIZE, [8/TAPETABLE,  8/03], <<FILE SEQ NUM>>  <<00828>>25240000
      <<030>> INTSIZE, [8/TAPETABLE,  8/04], <<REEL NUM>>      <<00828>>25242000
      <<031>> INTSIZE, [8/TAPETABLE,  8/05], <<SEQ TYPE>>      <<00828>>25244000
      <<032>> INTSIZE, [8/TAPETABLE,  8/06], <<CREATE DATE>>   <<00828>>25246000
      <<033>> INTSIZE, [8/TAPETABLE,  8/07], <<LABEL TYPE>>    <<00828>>25248000
                                                                        25250000
              << Interprocess communication >>                          25252000
                                                                        25254000
      <<034>> INTSIZE, [8/ACBTABLE,   8/13], <<# WRITERS>>     <<HM.00>>25256000
      <<035>> INTSIZE, [8/ACBTABLE,   8/14], <<# READERS>>     <<HM.00>>25258000
                                                                        25260000
              << Miscellaneous >>                                       25262000
                                                                        25264000
      <<036>> LOGSIZE, [8/FLABTABLE,  8/01], << Alloc date >>           25266000
      <<037>> DBLSIZE, [8/FLABTABLE,  8/02], << Alloc time >>           25268000
      <<038>> LOGSIZE, [8/ACBTABLE,   8/12], << DevfileID >>   <<00483>>25270000
      <<039>> LOGSIZE, [8/FCBTABLE,   8/06], <<first nz extnt>>         25272000
      <<040>> DBLSIZE, [8/ADHOCTABLE, 8/04], << disk status >> <<01115>>25274000
      <<041>> INTSIZE, [8/ADHOCTABLE, 8/07], << LDT type >>    <<01115>>25276000
      <<042>> INTSIZE, [8/ADHOCTABLE, 8/08], << LPDT subtype >><<01115>>25278000
      <<043>> 36,      [8/ADHOCTABLE, 8/09], << spoofle environment >>  25280000
      <<044>> INTSIZE, [8/FCBTABLE,   8/01], << nr. of last extent >>   25282000
      <<045>> 17,      [8/TAPETABLE,  8/08], << tapefile name>><<02545>>25284000
      <<046>> INTSIZE, [8/ADHOCTABLE, 8/10], << density >>     <<02560>>25286000
      <<047>> LOGSIZE, [8/ACBTABLE,   8/15], << DRT >>         <<03052>>25288000
      <<048>> LOGSIZE, [8/ACBTABLE,   8/16], << UNIT >>        <<03052>>25290000
      <<049>> INTSIZE, [8/ACBTABLE,   8/17], <<softint plabel>><<03657>>25292000
              0;  << Dummy -- always last >>                            25294000
ARRAY TOP(*)=FILENUM; <<FOR KSAM>>                             <<04876>>25296000
ARRAY DUMMY(0:11); <<FOR KSAM, must be last declaration)       <<04876>>25298000
                                                                        25300000
                                                                        25302000
   <<******************************>>                                   25304000
   <<  Subroutine CHECKPARM        >>                                   25306000
   <<******************************>>                                   25308000
                                                                        25310000
   INTEGER SUBROUTINE CHECKPARM;                                        25312000
      BEGIN                                                             25314000
      COMMENT:                                                          25316000
         On entry, PINDEX is PARMMASK LSR & parm index to next          25318000
         ITEMNUM/VAL pair.  Returns -1 if pair valid or missing.        25320000
         Otherwise, returns file sys error number.  ITEMNUM=0           25322000
         if both parameters missing.                                    25324000
         ;                                                              25326000
      CHECKPARM := -1;                                                  25328000
      IF PARMMASK&LSR(PINDEX-1) XOR PARMMASK&LSR(PINDEX) THEN           25330000
         BEGIN    << Not both present or missing. >>                    25332000
         CHECKPARM := NONPAIR;                                          25334000
         RETURN;                                                        25336000
         END;                                                           25338000
      ITEMNUM := PARM(-PINDEX);                                         25340000
      @ITEMVAL := PARM(X:=X+1);                                         25342000
      IF NOT PARMMASK&LSR(PINDEX) THEN ITEMNUM := 0;                    25344000
                             << both parameters missing >>              25346000
      IF ITEMNUM <> 0 THEN                                              25348000
         BEGIN                                                          25350000
         IF NOT (1 <= ITEMNUM <= MAXITEMNUM) THEN                       25352000
            BEGIN                                                       25354000
            CHECKPARM := NONITEM;                                       25356000
            RETURN;                                                     25358000
            END;                                                        25360000
         ITEMSIZE := ITEMDESC(ITEMNUM*DESCSIZE);                        25362000
         TABLENUM := ITEMDESC(X:=X+1).(0:8);                            25364000
         TABLEITEM := ITEMDESC(X).(8:8);                                25366000
         IF NOT FBNDCHK(@ITEMVAL,-ITEMSIZE,UBND) THEN          <<03059>>25368000
            BEGIN                                                       25370000
            CHECKPARM := BNDVIOL;                                       25372000
            RETURN;                                                     25374000
            END;                                                        25376000
         END;                                                           25378000
      END;    << subroutine CHECKPARM >>                                25380000
                                                                        25382000
                                                                        25384000
   <<******************************>>                                   25386000
   <<  Subroutine FINDINFO         >>                                   25388000
   <<******************************>>                                   25390000
                                                                        25392000
   LOGICAL SUBROUTINE FINDINFO(TABLENUM);                               25394000
   VALUE TABLENUM;                                                      25396000
   INTEGER TABLENUM;                                                    25398000
      BEGIN                                                             25400000
      COMMENT:                                                          25402000
         On entry, QINFOINDEX points to where we left off in            25404000
         search.  Search INFODESC for next parameter which is           25406000
         retrieved from table "TABLENUM".                               25408000
                                                                        25410000
         NOTE:  DB need not be at stack.                                25412000
         ;                                                              25414000
      WHILE (QINFOINDEX := QINFOINDEX+INFOSIZE) < QINFOLIMIT DO         25416000
         BEGIN                                                          25418000
         IF AQ0(QINFOINDEX) = TABLENUM THEN                             25420000
            BEGIN                                                       25422000
            TABLEITEM := AQ0(X:=X+1);                                   25424000
            QINFOPTR := AQ0(X:=X+1);                                    25426000
            ITEMSIZE := AQ0(X:=X+2);                                    25428000
            FINDINFO := TRUE;                                           25430000
            RETURN;                                                     25432000
            END;                                                        25434000
         END;                                                           25436000
      QINFOINDEX := QINFODESC-INFOSIZE;                                 25438000
                        << Reset to search from 1st param again >>      25440000
      FINDINFO := FALSE;                                                25442000
      END;    << subroutine FINDINFO >>                                 25444000
   <<******************************>>                                   25446000
   <<  Subroutine ZEROITEM         >>                                   25448000
   <<******************************>>                                   25450000
                                                                        25452000
   SUBROUTINE ZEROITEM;                                                 25454000
      BEGIN                                                             25456000
      COMMENT:                                                          25458000
         DB need not be at the stack.                                   25460000
         ;                                                              25462000
      I := (ITEMSIZE+1)/2;  <<ITEMSIZE in words>>                       25464000
      X := QINFOPTR-1;                                         <<00657>>25466000
      WHILE (I:=I-1) >= 0 DO AQ0(X:=X+1) := 0;                 <<00657>>25468000
      END;     << subroutine ZEROITEM >>                                25470000
                                                                        25472000
                                                                        25474000
   <<******************************>>                                   25476000
   <<  Main procedure body         >>                                   25478000
   <<******************************>>                                   25480000
                                                                        25482000
$  IF X0=ON                                                             25484000
   IF MONCALLABLE THEN                                                  25486000
      BEGIN                                                             25488000
      FTITLE("FFIL","EINF","O   ",0D);                                  25490000
      DEBUG;                                                            25492000
      END;                                                              25494000
$  IF                                                                   25496000
                                                                        25498000
   ERRORON;                                                             25500000
   CRIT := SETCRITICAL;                                                 25502000
                                                                        25504000
   IF NOT PARMMASK&LSR(FILEPARM) THEN                                   25506000
      BEGIN    << FILENUM missing -- can't do anything. >>              25508000
      TOS := INVFN;                                                     25510000
      TOS := CCL;                                                       25512000
      GO EXIT2;                                                         25514000
      END;                                                              25516000
   LOC'ACB(0,ACBMQ,FILENUM,UMODE);                             <<01672>>25518000
   DSTX := TOS;                                                         25520000
   IF < THEN                                                            25522000
      BEGIN      << Bad FNUM. >>                                        25524000
      TOS := INVFN;                                                     25526000
      TOS := CCL;                                                       25528000
      GO EXIT2;                                                         25530000
      END;                                                              25532000
   IF > THEN                                                            25534000
      BEGIN    << file is $NULL >>                                      25536000
      NULLFILE := TRUE;                                                 25538000
      ACB'FCB := 0;                                                     25540000
      LDEV := 0;                                                        25542000
      SPOOLED := 0;                                                     25544000
      AFTE := 0;                                               <<02028>>25546000
      NOFCB := TRUE;                                                    25548000
      LDT'DEVTYPE := 0;                                        <<02676>>25550000
      LPDT'SUBTYPE := 0;                                       <<02676>>25552000
      GO PREPROCESS;                                                    25554000
      END;                                                              25556000
                                                                        25558000
   IF DSTX <> 0 THEN                                                    25560000
      BEGIN      << DB not at stack. Barf >>                            25562000
      TOS := ILLDB;                                                     25564000
NFG:                                                                    25566000
      TOS := CCL;                                                       25568000
      GO EXIT;                                                          25570000
      END;                                                              25572000
   CASE * FTYPE OF                                                      25574000
      BEGIN                                                             25576000
      <<0>> BEGIN  << conventional file >>                              25578000
            END;                                                        25580000
                                                                        25582000
      <<1>> BEGIN  << remote file >>                                    25584000
            END;                                                        25586000
                                                                        25588000
      <<2>> GOTO BADFTYPE;                                              25590000
      <<3>> GOTO BADFTYPE;                                              25592000
      <<4>> GOTO BADFTYPE;                                              25594000
                                                                        25596000
      <<5>> BEGIN                                                       25598000
BADFTYPE:                                                               25600000
            TOS := SYSTEM;                                              25602000
            GOTO NFG;                                                   25604000
            END;                                                        25606000
                                                                        25608000
      <<6>> BEGIN  << KSAM file >>                                      25610000
              MOVE DUMMY:=TOP,(12); <<PARAM LIST ON TOS>>      <<04876>>25612000
              ASMB(PCAL KFILEINFO);                            <<04876>>25614000
              PUSH (STATUS);                                   <<04876>>25616000
              IF <> THEN                                       <<04876>>25618000
                CONDCODE:=CCL                                  <<04876>>25620000
              ELSE                                             <<04876>>25622000
                CONDCODE:=CCE;                                 <<04876>>25624000
              GO TO E2;                                        <<04876>>25626000
            END;                                                        25630000
      <<7>> GOTO BADFTYPE;                                     <<HM.00>>25632000
      <<8>> BEGIN  <<MSG FILE>>                                <<HM.00>>25634000
            END;                                               <<HM.00>>25636000
      END;  <<file type CASES>>                                         25638000
                                                                        25640000
                                                                        25642000
   <<******************************>>                                   25644000
   <<  Preprocess parameters       >>                                   25646000
   <<******************************>>                                   25648000
                                                                        25650000
   COMMENT:                                                             25652000
      Save any globally required info from ACB.                         25654000
      ;                                                                 25656000
   SPOOLED := ACB'SPOOLED;                                              25660000
   IF SPOOLED                                                  <<04161>>25662000
     THEN LDEV := ACBSPVDEV     << Virtual Ldev for spoolfile>><<04161>>25664000
   ELSE LDEV := ACB'DADDR;      << Real ldev for non spooled >><<04161>>25666000
                                                               <<04161>>25668000
   IF SPOOLED THEN @XDDEP := ACBSPXDDX;                        <<00483>>25670000
   LDT'DEVTYPE := LDEVTOTYPE(LDEV);                            <<01115>>25672000
   LPDT'SUBTYPE := LDEVTOSUBTYPE(LDEV);                        <<01115>>25674000
   NOFCB := IF SPOOLED OR (ACB'DTYPE=FDISC) THEN TRUE          <<01115>>25676000
            ELSE (ACB'DTYPE LAND %70) <> DIRACC;                        25678000
PREPROCESS:                                                             25680000
                                                                        25682000
   COMMENT:                                                             25684000
Preprocess parameter list to simplify table manipulation                25686000
later.  All bounds and consistency checking is done here.               25688000
We also determine table from which info is to be extracted.  In         25690000
most cases, this is a table look-up.  In a few cases, we must           25692000
make some decisions.                                                    25694000
   We build two tables here.  INFODESC, which is allocated              25696000
Q-relative at procedure entry, has six words per               <<01864>>25698000
entry, identifying what values the user wants, where he                 25700000
wants them, and how big they are.  Following this we allot              25702000
QINFODESC, which is local storage for the values to be                  25704000
returned.  INFODESC is built with pointers into QINFODESC.              25706000
                                                                        25708000
   Note:  Top of stack must be same before/after WHILE-loop             25710000
since we build "INFO" space there.       ;                              25712000
                                                                        25714000
   ACCESSTABLE := 0;                                                    25716000
   MOVE ACCESSTABLE(1) := ACCESSTABLE,(MAXTABLENUM);                    25718000
   INFOLIMIT := 0;                                                      25720000
   @INFO := @S0+1;                                                      25722000
   QINFOPTR := @INFO-@Q0;    << Q-relative pointer >>                   25724000
                                                                        25726000
   PINDEX := ITEM1PARM+2;                                               25728000
   WHILE (PINDEX := PINDEX-2) >= 0 DO                                   25730000
      BEGIN                                                             25732000
      X := CHECKPARM;                                                   25734000
      IF X >= 0 THEN                                                    25736000
         BEGIN                                                          25738000
         TOS := X;                                                      25740000
         GOTO NFG;                                                      25742000
         END;                                                           25744000
      IF ITEMNUM <> 0 THEN                                              25746000
         BEGIN     << process item >>                                   25748000
         IF TABLENUM = 0 THEN                                           25750000
            BEGIN   << handle special cases >>                          25752000
            COMMENT:                                                    25754000
   Handle cases where table from which info is retrieved                25756000
depends on conditions.  Each case will redefine TABLENUM and            25758000
TABLEITEM.  Actual retrieval of info is below as usual.   ;             25760000
                                                                        25762000
            CASE TABLEITEM OF                                           25764000
               BEGIN                                                    25766000
               <<00>> TABLENUM := 0;  <<invalid ITEMNUM>>               25768000
               END;                                                     25770000
            END;    << special cases >>                                 25772000
                                                                        25774000
         IF TABLENUM = 0 THEN                                           25776000
            BEGIN     << Invalid ITEMNUM. >>                            25778000
            TOS := NONITEM;                                             25780000
            GOTO NFG;                                                   25782000
            END;                                                        25784000
         IF NOT (1 <= TABLENUM <= MAXTABLENUM) THEN                     25786000
            BEGIN                                                       25788000
            TOS := SYSTEM;                                              25790000
            GOTO NFG;                                                   25792000
            END;                                                        25794000
         INFODESC(INFOLIMIT) := TABLENUM;                               25796000
         INFODESC(X:=X+1) := TABLEITEM;                                 25798000
         INFODESC(X:=X+1) := QINFOPTR;                                  25800000
         INFODESC(X:=X+1) := @ITEMVAL;                                  25802000
         INFODESC(X:=X+1) := ITEMSIZE;                                  25804000
         INFODESC(X:=X+1) := ITEMNUM;                          <<01864>>25806000
         INFOLIMIT := X+1;    << next INFODESC entry >>                 25808000
         ACCESSTABLE(TABLENUM) := TRUE;                                 25810000
         QINFOPTR := (ITEMSIZE+1)/2 + QINFOPTR;  << next addr >>        25812000
         END;     << process item >>                                    25814000
      END;     <<WHILE>>                                                25816000
   TOS := QINFOPTR-(@INFO-@Q0);   << allocate info space >>             25818000
   RFA'BUF'LENGTH := S0;   << Need length here too for DS.  >> <<01864>>25820000
   ASSEMBLE(ADDS 0);                                                    25822000
   QINFODESC := @INFODESC-@Q0;    << Q-relative pntrs >>                25824000
   QINFOINDEX := QINFODESC-INFOSIZE;                                    25826000
   QINFOLIMIT := QINFODESC+INFOLIMIT;                                   25828000
                                                                        25830000
   IF FTYPE = REMOTE'FILE THEN                                 <<01864>>25832000
      BEGIN                                                    <<01864>>25834000
                                                               <<01864>>25836000
<<******************************>>                             <<01864>>25838000
<<   FFILEINFO on remote file   >>                             <<01864>>25840000
<<******************************>>                             <<01864>>25842000
                                                               <<01864>>25844000
COMMENT --                                                     <<01864>>25846000
  This section builds the message array for the  DS  interface <<01864>>25848000
procedure  MANAGEWRITECONVERSATION,  calls  the  procedure and <<01864>>25850000
then processes the results.  In keeping with the other intrin- <<01864>>25852000
sics, the message array will be built on the top of stack, al- <<01864>>25854000
though maintenance of such a structure can be quite difficult. <<01864>>25856000
The other side of the coin is that the array is allocated only <<01864>>25858000
when needed (that is, for accessing a remote file), thus  con- <<01864>>25860000
serving the stack.                                             <<01864>>25862000
  In addition to the message array, we pass DS the DB-relative <<01864>>25864000
address of the INFO array (@INFO).  The remote FFILEINFO  sets <<01864>>25866000
its  output  in  here and returns, making it seem as though we <<01864>>25868000
had done it.  We can then proceed directly to COPY'DATA.       <<01864>>25870000
  The fully-built stack (just before the call to  MANAGEWRITE- <<01864>>25872000
CONVERSATION) looks like this:                                 <<01864>>25874000
                                                               <<01864>>25876000
    +-------------------------------+                          <<01864>>25878000
    | INFO - space for returned data|                          <<01864>>25880000
    +-------------------------------+                          <<01864>>25882000
    | Message array (appendage) for |                          <<01864>>25884000
    | MANAGEWRITECONVERSATION       |                          <<01864>>25886000
    | (see below)                   |                          <<01864>>25888000
    +-------------------------------+                          <<01864>>25890000
    | DS parameters                 | \                        <<01864>>25892000
    | . . . . . . . . . . . . . . . |  \                       <<01864>>25894000
    | @appendage (stack-DB-relative)|   |                      <<01864>>25896000
    | . . . . . . . . . . . . . . . |   |                      <<01864>>25898000
    | Length of appendage           |   |                      <<01864>>25900000
    | . . . . . . . . . . . . . . . |   |                      <<01864>>25902000
    | @data array TO remote (0)     |   |  MANAGEWRITE-        <<01864>>25904000
    | . . . . . . . . . . . . . . . |    > CONVERSATION        <<01864>>25906000
    | Length of TO array (0)        |   |  parameters          <<01864>>25908000
    | . . . . . . . . . . . . . . . |   |                      <<01864>>25910000
    | @data array FROM remote       |   |                      <<01864>>25912000
    | (@INFO)                       |   |                      <<01864>>25914000
    | . . . . . . . . . . . . . . . |   |                      <<01864>>25916000
    | Length of FROM array          |  /                       <<01864>>25918000
    | (RFA'BUF'LENGTH)              | /                        <<01864>>25920000
    +-------------------------------+                          <<01864>>25922000
                                                               <<01864>>25924000
  Detail of message array for MANAGEWRITECONVERSATION:         <<01864>>25926000
                                                               <<01864>>25928000
                         1 1 1 1 1 1                           <<01864>>25930000
     0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5                           <<01864>>25932000
    +-------------------------------+                          <<01864>>25934000
    |      "R"      |      "F"      |                          <<01864>>25936000
    +-------------------------------+                          <<01864>>25938000
    |      "A"      |     blank     |                          <<01864>>25940000
    +-------------------------------+                          <<01864>>25942000
    | FFILEINFO DS-code (= %64)     |                          <<01864>>25944000
    +-------------------------------+                          <<01864>>25946000
    | RFA file number               |                          <<01864>>25948000
    +-------------------------------+                          <<01864>>25950000
    | ITEMNUM1 parameter            |                          <<01864>>25952000
    +-------------------------------+                          <<01864>>25954000
    | ITEMVALUE1 data length        |                          <<01864>>25956000
    +-------------------------------+                          <<01864>>25958000
    | ITEMNUM2 parameter            |                          <<01864>>25960000
    +-------------------------------+                          <<01864>>25962000
    | ITEMVALUE2 data length        |                          <<01864>>25964000
    +-------------------------------+                          <<01864>>25966000
    | ITEMNUM3 parameter            |                          <<01864>>25968000
    +-------------------------------+                          <<01864>>25970000
    | ITEMVALUE3 data length        |                          <<01864>>25972000
    +-------------------------------+                          <<01864>>25974000
    | ITEMNUM4 parameter            |                          <<01864>>25976000
    +-------------------------------+                          <<01864>>25978000
    | ITEMVALUE4 data length        |                          <<01864>>25980000
    +-------------------------------+                          <<01864>>25982000
    | ITEMNUM5 parameter            |                          <<01864>>25984000
    +-------------------------------+                          <<01864>>25986000
    | ITEMVALUE5 data length        |                          <<01864>>25988000
    +-------------------------------+                          <<01864>>25990000
    | OPTION VARIABLE mask          |                          <<01864>>25992000
    +-------------------------------+                          <<01864>>25994000
                                                               <<01864>>25996000
Note that "data length" of ITEMVALUE is passed rather than the <<01864>>25998000
ITEMVALUE itself or its address.  This fixes the length of the <<01864>>26000000
message array and makes remote buffer management easier. Since <<01864>>26002000
all items are optional, the "data length" of all unused  items <<01864>>26004000
is  set  to 0, in addition to clearing appropriate bits in the <<01864>>26006000
OPTION VARIABLE mask.  In addition, items in the message array <<01864>>26008000
are "crunched", that is, all items which are present appear in <<01864>>26010000
the lower-numbered "ITEMNUM's" above.  This is  a  consequence <<01864>>26012000
of the PREPROCESS code just before ours.                       <<01864>>26014000
                                                               <<01864>>26016000
The DS interface generates four reply structures:              <<01864>>26018000
  a)  A Head Section, used only by DS, which we never see.     <<01864>>26020000
  b)  An Appendage section consisting only of the remote       <<01864>>26022000
      FFILEINFO  status word.  It overlays (the first word of) <<01864>>26024000
      our appendage, that is, our message array.               <<01864>>26026000
  c)  A Data section, which goes into INFO.                    <<01864>>26028000
  d)  The one-word result of MANAGEWRITECONVERSATION, which is <<01864>>26030000
      the actual length of the data placed in RFA'BUFFER. This <<01864>>26032000
      result is discarded.                                     <<01864>>26034000
;                                                              <<01864>>26036000
      IF INFOLIMIT = 0 THEN                                    <<01864>>26038000
         BEGIN   << No parameters, skip the DS call.        >> <<01864>>26040000
         TOS := 0;                                             <<01864>>26042000
         TOS := CCE;                                           <<01864>>26044000
         GO EXIT;                                              <<01864>>26046000
         END;                                                  <<01864>>26048000
      SETRFAPTR;     << Build message array on TOS.         >> <<01864>>26050000
      RFALEN := 15;  << Length of message array (appendage) >> <<01864>>26052000
      TOS := "RFA ";                                           <<01864>>26054000
      TOS := %64;    << FFILEINFO DS code = intrinsic no.   >> <<01864>>26056000
      TOS := RFAFILE;                                          <<01864>>26058000
                                                               <<01864>>26060000
COMMENT --                                                     <<01864>>26062000
  Stack parameters actually present, then add 0 for others.    <<01864>>26064000
Account for presence or absence of parameters in RFA'PARMMASK. <<01864>>26066000
We can't use FFILEINFO's PARMMASK because PREPROCESS may  have <<01864>>26068000
crunched our parameters.  We can't use FOR loops because we're <<01864>>26070000
diddling the stack.                                            <<01864>>26072000
;                                                              <<01864>>26074000
      RFA'PARMMASK := 1;   << FILENUM is always there.      >> <<01864>>26076000
      I := 5;                                                  <<01864>>26078000
      WHILE I < INFOLIMIT DO                                   <<01864>>26080000
         BEGIN   << Stack existing parameters >>               <<01864>>26082000
         TOS := INFODESC(I);           << Current ITEMNUM.  >> <<01864>>26084000
         TOS := INFODESC(X := X-1);    << Current ITEMSIZE. >> <<01864>>26086000
         RFA'PARMMASK := RFA'PARMMASK&LSL(2)+3;                <<01864>>26088000
         I := I + INFOSIZE;            << Next entry.       >> <<01864>>26090000
         END;                                                  <<01864>>26092000
      WHILE I < 5*INFOSIZE DO                                  <<01864>>26094000
         BEGIN   << Stack 0 for missing parameters.         >> <<01864>>26096000
         TOS := 0D;                                            <<01864>>26098000
         RFA'PARMMASK := RFA'PARMMASK & LSL(2);                <<01864>>26100000
         I := I + INFOSIZE;                                    <<01864>>26102000
         END;   << of stacking omitted parameters.          >> <<01864>>26104000
      TOS := RFA'PARMMASK;                                     <<01864>>26106000
      GETMWCPARMS;      << Stack MANAGEWRITE... boilerplate.>> <<01864>>26108000
      TOS := 0D;        << Not passing any data.            >> <<01864>>26110000
      TOS := @INFO;            << But we're getting...      >> <<01864>>26112000
      TOS := RFA'BUF'LENGTH;   << ...some back.             >> <<01864>>26114000
      TOS := MWCPLABEL;                                        <<01864>>26116000
      ASSEMBLE (PCAL 0);       << Thar she blows!           >> <<01864>>26118000
      DEL;                     << Don't need xfr length.    >> <<01864>>26120000
      CHECKXFER;   << Checks for DS err, not FFILEINFO err. >> <<01864>>26122000
      DELAPPENDAGE;   << Cut back stack except for status.  >> <<01864>>26124000
      TOS := TOS.CC;   << This is remote FFILEINFO CC.      >> <<01864>>26126000
      ASSEMBLE(ZERO,XCH);     << Report no FSERR here.      >> <<01864>>26128000
      IF S0 <> CCE THEN GO EXIT;   << Remote FFILEINFO err. >> <<01864>>26130000
      DDEL;              << Don't need status, FSERR here.  >> <<01864>>26132000
      GO COPY'DATA;      << Copy data to user's buffer, exit>> <<01864>>26134000
      END;               << of FFILEINFO to remote file.    >> <<01864>>26136000
                                                                        26138000
   <<******************************>>                                   26140000
   <<  Ad Hoc information          >>                                   26142000
   <<******************************>>                                   26144000
                                                                        26146000
   COMMENT:                                                             26148000
      To expedite first implementation, FGETINFO parameters             26150000
      are handled by calling FGETINFO for each.  This is                26152000
      grossly inefficient.  A second-pass implementation                26154000
      should copy relevant portions of FGETINFO into here.              26156000
      Ideally, body of FGETINFO should be replaced by calls             26158000
      to FFILEINFO to avoid code duplication.                           26160000
      ;                                                                 26162000
                                                                        26164000
   IF NOT ACCESSTABLE(ADHOCTABLE) THEN GOTO END'ADHOC;                  26166000
   FINDINFO(ADHOCTABLE);                                                26168000
LOOP'ADHOC:                                                             26170000
   CASE TABLEITEM OF                                                    26172000
      BEGIN                                                             26174000
      <<00>> BEGIN  << file name >>                            <<01115>>26176000
             FGETINFO(FILENUM,AQ0(QINFOPTR)); FGIERR;          <<01115>>26178000
             END;                                                       26180000
                                                                        26182000
      <<01>> BEGIN  << record size >>                          <<01115>>26184000
             FGETINFO(FILENUM,,,,AQ0(QINFOPTR)); FGIERR;       <<01115>>26186000
             END;                                              <<01115>>26188000
                                                                        26190000
      <<02>> BEGIN  << device type >>                          <<01115>>26192000
             FGETINFO(FILENUM,,,,,AQ0(QINFOPTR)); FGIERR;      <<01115>>26194000
             END;                                              <<01115>>26196000
                                                                        26198000
      <<03>> BEGIN  <<HDADDR>>                                 <<01115>>26200000
             FGETINFO(FILENUM,,,,,,,AQ0(QINFOPTR));            <<03052>>26202000
             IF <> THEN GO TO NFG;                             <<03092>>26204000
             END;                                              <<01115>>26208000
                                                                        26210000
      <<04>> BEGIN  << disc status >>                          <<01115>>26212000
             IF NOT NULLFILE AND                               <<01115>>26214000
                (LDT'DEVTYPE=0 OR LDT'DEVTYPE=2)               <<01115>>26216000
               THEN TOS := REQSTATUS(LDEV)                     <<01115>>26218000
               ELSE TOS := 0D;                                 <<01115>>26220000
             STD'QINFOPTR;                                     <<01115>>26222000
             END;                                              <<01115>>26224000
                                                                        26226000
                                                                        26228000
      <<05>> BEGIN  << Logical block size >>                            26230000
             FGETINFO(FILENUM,,,,,,,,,,,,,,AQ0(QINFOPTR)); FGIERR;      26232000
             END;                                                       26234000
                                                                        26236000
      <<06>> BEGIN   << file limit >>                          <<01115>>26238000
             FGETINFO(FILENUM,,,,, ,,,,, , AQ0(QINFOPTR));FGIERR;<<FDF>>26240000
             END;                                              <<01115>>26242000
      <<07>> AQ0(QINFOPTR):=LDT'DEVTYPE;                       <<01115>>26246000
      <<08>> AQ0(QINFOPTR):=LPDT'SUBTYPE;                      <<01115>>26248000
      <<09>> BEGIN                                                      26250000
             IF SPOOLED                                        <<04611>>26252000
               THEN BEGIN                                      <<04611>>26254000
                 ALLOCFLAB;                                    <<04611>>26256000
                 FREADLABEL(FILENUM,ULABEL,128,0);             <<04611>>26258000
                 IF <> THEN                                    <<04611>>26260000
                    BEGIN       << Error. >>                   <<04611>>26262000
                    ASMB(SUBS 128);   << deallocate buffer >>  <<04611>>26264000
                    TOS := LBLIOERR;                           <<04611>>26266000
                    GO NFG;                                    <<04611>>26268000
                    END;                                       <<04611>>26270000
                 MOVE AQ0(QINFOPTR) := SPULAB'LAST'ENV,(18);   <<04611>>26272000
                 ASMB(SUBS 128);    << deallocate buffer >>    <<04611>>26274000
                 END                                           <<04611>>26276000
               ELSE MOVE AQ0(QINFOPTR) := "                  ";<<04611>>26278000
             END;                                                       26280000
      <<10>> BEGIN             << Tape file density >>         <<02676>>26284000
                                                               <<02676>>26286000
             << If file does not reside on a variable   >>     <<02676>>26288000
             << density tape drive, then return a zero. >>     <<02676>>26290000
                                                               <<02676>>26292000
             IF NULLFILE OR LDT'DEVTYPE <> MTAPE OR            <<02676>>26294000
               LPDT'SUBTYPE.(13:3) <> HP7976 THEN              <<02676>>26296000
                ZEROITEM                                       <<02676>>26298000
             ELSE                                              <<02676>>26300000
                BEGIN   << Variable density drive. >>          <<02676>>26302000
                                                               <<02676>>26304000
                << Get density word from LDT >>                <<02676>>26306000
                TOS := @LDT'DENW;                              <<02676>>26308000
                TOS := LDT;                                    <<02676>>26310000
                TOS := LDEV*LDTENTRY + DENSITYW;               <<02676>>26312000
                TOS := 1;                                      <<02676>>26314000
                ASSEMBLE( MFDS 4 );                            <<02676>>26316000
                                                               <<02676>>26318000
                << Return actual tape density unless at load >><<02676>>26320000
                << point and access is other than read only. >><<02676>>26322000
                IF LPDT'BOT AND ACB'ACTYPE <> 0 THEN           <<02676>>26324000
                   TOS := REQUEST'DENSITY                      <<02676>>26326000
                ELSE                                           <<02676>>26328000
                   TOS := TAPE'DENSITY;                        <<02676>>26330000
                                                               <<02676>>26332000
                << Return density as BPI >>                    <<02676>>26334000
                AQ0(QINFOPTR) := IF TOS = DEN'1600 THEN 1600   <<02676>>26336000
                                                   ELSE 6250;  <<02676>>26338000
                END;   << of variable density drive >>         <<02676>>26340000
             END;   << of tape file density >>                 <<02676>>26342000
      END;                                                              26344000
   IF FINDINFO(ADHOCTABLE) THEN GOTO LOOP'ADHOC;                        26346000
END'ADHOC:                                                              26348000
                                                                        26350000
                                                                        26352000
   <<******************************>>                                   26354000
   <<  ACB information             >>                                   26356000
   <<******************************>>                                   26358000
                                                                        26360000
   IF NOT ACCESSTABLE(ACBTABLE) THEN GOTO END'ACB;                      26362000
   IF NULLFILE THEN                                                     26364000
      BEGIN      << $NULL >>                                            26366000
      WHILE FINDINFO(ACBTABLE) DO                              <<00899>>26368000
         BEGIN                                                 <<00899>>26370000
         IF TABLEITEM = ACBFOPITEM THEN                        <<00899>>26372000
            AQ0(QINFOPTR) := NULLFOP                           <<00899>>26374000
         ELSE IF TABLEITEM = ACBAOPITEM THEN                   <<00899>>26376000
            AQ0(QINFOPTR) := NULLAOP                           <<00899>>26378000
         ELSE ZEROITEM;                                        <<00899>>26380000
         END;      << WHILE-DO on FINDINFO >>                  <<00899>>26382000
      GOTO END'ACB;                                                     26384000
      END;       << $NULL >>                                            26386000
   FINDINFO(ACBTABLE);                                                  26388000
LOOP'ACB:                                                               26390000
   CASE TABLEITEM OF                                                    26392000
      BEGIN                                                             26394000
      <<00>> AQ0(QINFOPTR) := IF SPOOLED THEN ACBSPFOPT                 26396000
                              ELSE ACB'FOPTIONS;                        26398000
                                                                        26400000
      <<01>> AQ0(QINFOPTR) := IF SPOOLED THEN ACBSPAOPT                 26402000
                 LAND %177357 ELSE ACB'AOPTIONS;                        26404000
                                                                        26406000
      <<02>> BEGIN   << logical device nr. >>                           26408000
             AQ0(QINFOPTR) := LDEV;                            <<04161>>26410000
             END;                                                       26414000
                                                                        26416000
      <<03>> BEGIN   << record pointer >>                               26418000
             TOS := ACB'FPTR;                                           26420000
             STD'QINFOPTR;                                              26422000
             END;                                                       26424000
                                                                        26426000
      <<04>> BEGIN   << record [logical] transfer count >>              26428000
             TOS := ACBRTFRCT;                                          26430000
             STD'QINFOPTR;                                              26432000
             END;                                                       26434000
                                                                        26436000
      <<05>> BEGIN   << block [physical] transfer count >>              26438000
             TOS := IF SPOOLED THEN ACBRTFRCT ELSE ACBBTFRCT;           26440000
             STD'QINFOPTR;                                              26442000
             END;                                                       26444000
                                                                        26446000
      <<06>> AQ0(QINFOPTR) := ACB'BLKFACT;                              26448000
      <<07>> AQ0(QINFOPTR) := ACBBSIZE;  << phys blk size >>            26450000
                                                                        26452000
      <<08>> BEGIN   << data block size >>                              26454000
             AQ0(QINFOPTR) := (ACBRSIZE+1)/2 * ACB'BLKFACT;             26456000
             END;                                                       26458000
                                                                        26460000
      <<09>> AQ0(QINFOPTR) := 0;  << offset to blk data >>              26462000
                                                                        26464000
      <<10>> BEGIN    << RIO "ART" offset >>                            26466000
             AQ0(QINFOPTR) := IF NOT ACBRIO THEN 0                      26468000
                              ELSE (ACBRSIZE+1)/2 * ACB'BLKFACT;        26470000
             END;                                                       26472000
                                                                        26474000
      <<11>> BEGIN    << RIO "ART" size >>                              26476000
             AQ0(QINFOPTR) := IF NOT ACBRIO THEN 0                      26478000
                              ELSE (ACB'BLKFACT+16)/16;                 26480000
             END;                                                       26482000
                                                                        26484000
      <<12>> BEGIN   << Spooled devicefileID >>                <<00483>>26486000
                     << Always return zero if not spooled >>            26488000
             AQ0(QINFOPTR) := IF SPOOLED THEN LOGICAL(         <<00483>>26490000
               XDDSPOOLINFO(0D, %4000, XDDEP)) ELSE 0;         <<00483>>26492000
             END;                                              <<00483>>26494000
      <<13>> BEGIN   << Number of writers >>                   <<HM.00>>26496000
             AQ0(QINFOPTR):=(ACBSHCNT-ACBSHCNTIN);             <<HM.00>>26498000
             END;                                              <<HM.00>>26500000
                                                               <<HM.00>>26502000
      <<14>> BEGIN   << Number of readers >>                   <<HM.00>>26504000
             AQ0(QINFOPTR):=ACBSHCNTIN;                        <<HM.00>>26506000
             END;                                              <<HM.00>>26508000
      <<15>> BEGIN   << DRT >>                                 <<03052>>26510000
             AQ0(QINFOPTR) := IF SPOOLED THEN 0 ELSE           <<03052>>26512000
             LDEVTODRT(ACB'DADDR).(7:9);                       <<03052>>26514000
             END;                                              <<03052>>26516000
      <<16>> BEGIN   << UNIT >>                                <<03052>>26518000
             AQ0(QINFOPTR) := IF SPOOLED THEN 0 ELSE           <<03052>>26520000
             LDEVTODRT(ACB'DADDR)&LSR(9);                      <<03052>>26522000
             END;                                              <<03052>>26524000
      <<17>> BEGIN  << SOFTWARE INTERRUPT PLABEL >>            <<03657>>26526000
             IF NOT ACBMSGFILE THEN                            <<03038>>26528000
                AQ0(QINFOPTR):=0                               <<03038>>26530000
             ELSE                                              <<03038>>26532000
                FCGETINFO(ACBMQ,0,AQ0(QINFOPTR));              <<03038>>26534000
             END;                                              <<03038>>26536000
      END;                                                     <<03038>>26538000
   IF FINDINFO(ACBTABLE) THEN GOTO LOOP'ACB;                            26540000
END'ACB:                                                                26542000
                                                                        26544000
                                                                        26546000
   <<******************************>>                                   26548000
   <<  FCB information             >>                                   26550000
   <<******************************>>                                   26552000
                                                                        26554000
   IF NOT ACCESSTABLE(FCBTABLE) THEN GOTO END'FCB;                      26556000
   IF NOFCB THEN                                                        26558000
      BEGIN       << Return zero for all FCB items. >>                  26560000
      WHILE FINDINFO(FCBTABLE) DO                              <<00899>>26562000
         BEGIN                                                 <<00899>>26564000
         ZEROITEM;                                             <<00899>>26566000
         END;                                                  <<00899>>26568000
      GOTO END'FCB;                                                     26570000
      END;                                                              26572000
   PUSH(S);                                                             26574000
   @FCB := TOS+1;                                                       26576000
   ASMB(ADDS SIZEDFCB);   << allocate FCB buffer >>                     26578000
   LOCK'CB(0,0,@FCB-@Q0,ACB'FCB.DSTN,ACB'FCB VTA);                      26580000
   TOS := SIZEBFCB;                                                     26582000
   MOVE'DS'1;         << Copy FCB to stack >>                           26584000
   TOS := (FCBNUMEXTS+1)&LSL(1);                               <<01672>>26586000
   MOVE'DS'6;         << Get E-map too >>                               26588000
   FINDINFO(FCBTABLE);                                                  26590000
LOOP'FCB:                                                               26592000
   CASE TABLEITEM OF                                                    26594000
      BEGIN                                                             26596000
      <<00>> BEGIN                                                      26598000
             TOS := FCBEOF;                                             26600000
             STD'QINFOPTR;                                              26602000
             END;                                                       26604000
                                                                        26606000
      <<01>> BEGIN     << Last extent used >>                           26608000
             TOS := FCBNUMEXTS;   << extent index >>           <<02675>>26610000
             TOS := @FCBEXTMAP+FCBNUMEXTS&LSL(1);  << e-map ptr >>      26612000
             WHILE DPS0 = 0D DO                                <<02675>>26614000
                BEGIN     << Look for existing extent. >>               26616000
                S0 := S0-2;     << Decr XMAP pointer >>                 26618000
                S1 := S1-1;     << decr index >>                        26620000
                END;                                                    26622000
             DEL;          << discard pointer >>                        26624000
             AQ0(QINFOPTR) := TOS+1;                           <<02675>>26626000
             END;                                              <<*****>>26628000
                                                                        26630000
      <<02>> AQ0(QINFOPTR) := FCBEXTSIZE;                               26632000
      <<03>> AQ0(QINFOPTR) := FCBNUMEXTS+1;                             26634000
      <<04>> AQ0(QINFOPTR) := FCBLBL;  << user labels >>                26636000
                                                                        26638000
      <<05>> BEGIN                                                      26640000
             TOS := FLABADDR := FCBLABEL;                               26642000
             STD'QINFOPTR;                                              26644000
             END;                                                       26646000
      <<06>> BEGIN     << First nonzero extent (spoofle) >>    <<*****>>26648000
             TOS := 0;   << extent index >>                             26650000
             TOS := @FCBEXTMAP;   << extent map pointer >>              26652000
             IF FCBNUMEXTS >= 2 THEN                           <<01624>>26654000
                DO BEGIN     << Look for existing extent. >>            26656000
                S0 := S0+2;     << Bump XMAP pointer >>                 26658000
                S1 := S1+1;     << bump index >>                        26660000
                END UNTIL DPS0 <> 0D;                                   26662000
             DEL;          << discard pointer >>                        26664000
             IF S0 = 1 THEN S0 := 0;   << All exts present >>           26666000
             AQ0(QINFOPTR) := TOS;                                      26668000
             END;                                              <<*****>>26670000
      END;                                                              26672000
   IF FINDINFO(FCBTABLE) THEN GOTO LOOP'FCB;                            26674000
   UNLOCK'CB(0,ACB'FCB.DSTN,ACB'FCB VTA);                               26676000
   ASMB(SUBS SIZEDFCB);                                                 26678000
END'FCB:                                                                26680000
                                                                        26682000
   <<******************************>>                                   26684000
   <<  File label information      >>                                   26686000
   <<******************************>>                                   26688000
                                                                        26690000
   IF NOT ACCESSTABLE(FLABTABLE) THEN GOTO END'FLAB;                    26692000
   ALLOCFLAB;                                                           26694000
   IF NOFCB THEN                                                        26696000
      BEGIN     << Zero file label. >>                                  26698000
      FLAB := 0;                                                        26700000
      MOVE FLAB(1) := FLAB,(127);                                       26702000
      GO FIRST'FLAB;                                                    26704000
      END;                                                              26706000
                                                                        26708000
   IF FLABADDR = 0D THEN                                                26710000
      FLABADDR := GETFCB'INFO (ACB'FCB, SIZEBFCB);             <<01624>>26712000
   SECTOR := FLABADDR;                                                  26714000
   ISECTOR.(0:8) := 0;    << clear LDEV >>                              26716000
   TOS := FISIR;          << for "RELSIR">>                             26718000
   TOS := GETSIR(FISIR);                                                26720000
   X := FLABIO(LDEV,SECTOR,0,FLAB);                                     26722000
   RELSIR(*,*);                                                         26724000
   IF X <> 0 THEN                                                       26726000
      BEGIN                                                             26728000
      FLABIOERR(X,FILENUM);  << flag directory >>                       26730000
      DEALLOCFLAB;                                                      26732000
      TOS := LBLIOERR;                                                  26734000
      GOTO NFG;                                                         26736000
      END;                                                              26738000
FIRST'FLAB:                                                             26740000
   FINDINFO(FLABTABLE);                                                 26742000
LOOP'FLAB:                                                              26744000
   CASE TABLEITEM OF                                                    26746000
      BEGIN                                                             26748000
      <<00>> BEGIN     << Creator ID >>                                 26750000
             IF NOFCB THEN MOVE AQ0(QINFOPTR) := "        "             26752000
             ELSE MOVE AQ0(QINFOPTR) := FLUSERID,(4);                   26754000
             END;                                                       26756000
                                                                        26758000
      <<01>> AQ0(QINFOPTR) := FLALLOCDATE;                              26760000
                                                                        26762000
      <<02>> BEGIN                                                      26764000
             TOS := FLALLOCTIME;                                        26766000
             STD'QINFOPTR;                                              26768000
             END;                                                       26770000
      <<03>> AQ0(QINFOPTR) := FLFILECODE;  << file code >>     <<00483>>26772000
      END;                                                              26774000
   IF FINDINFO(FLABTABLE) THEN GOTO LOOP'FLAB;                          26776000
   DEALLOCFLAB;                                                         26778000
END'FLAB:                                                               26780000
                                                                        26782000
   <<********************************>>                        <<00828>>26784000
   <<  Tape label table information  >>                        <<00828>>26786000
   <<********************************>>                        <<00828>>26788000
                                                               <<00828>>26790000
   IF NOT ACCESSTABLE(TAPETABLE) THEN GO ENDTAPE;              <<00828>>26792000
   FINDINFO(TAPETABLE);                                        <<00828>>26796000
LOOPTAPE:                                                      <<00828>>26798000
   TGETINFO(LDEV,AQ0(QINFOPTR),TABLEITEM);    << DB at stack >><<02545>>26802000
   IF FINDINFO(TAPETABLE) THEN GOTO LOOPTAPE;                  <<00828>>26804000
ENDTAPE:                                                       <<00828>>26808000
                                                                        26810000
   <<******************************>>                                   26812000
<< Now copy the accumulated data to the user's buffers. >>              26814000
   <<******************************>>                                   26816000
                                                                        26818000
COPY'DATA:                                                     <<01864>>26820000
   FOR I := 0 STEP INFOSIZE UNTIL INFOLIMIT-1 DO                        26822000
      BEGIN                                                             26824000
      QINFOPTR := INFODESC(I+2);                                        26826000
      TOS := INFODESC(X:=X+1);                                          26828000
      TOS := @AQ0(QINFOPTR)&LSL(1);                                     26830000
      MOVE * := *,(INFODESC(I+4));                                      26832000
      END;                                                              26834000
   TOS := 0;     << no error >>                                         26836000
   TOS := CCE;                                                          26838000
                                                                        26840000
EXIT:                                                                   26842000
   COMMENT:                                                             26844000
      S-1 = Filesys error number                                        26846000
      S-0 = condition code                                              26848000
      DB  = at stack.  We must not have anything locked.                26850000
      ;                                                                 26852000
   IF NOT NULLFILE AND                                         <<02068>>26854000
     (FTYPE = FS'TYPE OR FTYPE = MSG'TYPE) THEN                <<02068>>26856000
      BEGIN   << Log any FSERR and unlock ACB.              >> <<01624>>26858000
      ACB'ERROR := S1;                                         <<01624>>26860000
      UNLOC'ACB(ACBMQ,0);                                      <<01672>>26862000
      END;                                                     <<01624>>26864000
EXIT2:                                                                  26866000
   CONDCODE := TOS;                                                     26868000
E2:RESETCRITICAL(CRIT);                                        <<04876>>26870000
   ERROREXIT(CALLSEQSIZE,S0,0);                                         26872000
   END;  << procedure FFILEINFO >>                                      26874000
$PAGE " FREADLABEL - FWRITELABEL "                                      26876000
$CONTROL SEGMENT = FILESYS3   << FREADLABEL/FWRITELABEL >>              26878000
PROCEDURE FREADLABEL(FN,TARGET,TCOUNT,LBL);<<and FWRITELABEL>>          26880000
VALUE FN,TCOUNT,LBL;                                                    26882000
INTEGER FN,TCOUNT,LBL;                                                  26884000
ARRAY TARGET;                                                           26886000
OPTION PRIVILEGED,VARIABLE;                                             26888000
   BEGIN                                                                26890000
   ENTRY FWRITELABEL;                                                   26892000
   EQUATE UBND =  -9; <<Q rel upper bound for bound check>>    <<03059>>26894000
   LOGICAL PMAP = Q-4;    << Param. bit map >>                          26896000
   LOGICAL CODE;          << Read (0) or Write (1)>>                    26898000
   DEFINE READ = NOT CODE#,                                             26900000
          WRITE = CODE#;                                                26902000
   INTEGER CRIT;          << for SETCRITICAL >>                         26904000
   INTEGER ACCTYPE;       << access class >>                            26906000
   INTEGER DTYPE;         << device type >>                    <<01115>>26908000
   DOUBLE STKADR,FCBADR;                                                26910000
   INTEGER LDEV;           << User label LDEV >>                        26912000
   DOUBLE DISKADR;         << User label sector nr. >>                  26914000
   INTEGER P1 = DISKADR;   << sector nr. - first half >>                26916000
   INTEGER P2 = DISKADR+1;  << sector nr. - second half >>              26918000
                                                                        26920000
   << Remote file access (RFA) variables: >>                            26922000
                                                                        26924000
   INTEGER POINTER RFAPTR;   << appendage pointer >>           <<DS.00>>26926000
   INTEGER RFALEN;           << appendage length >>            <<DS.00>>26928000
                                                                        26930000
<< Following LOC'ACB params must be in order: >>                        26932000
   INTEGER AFTE;                                                        26934000
   INTEGER PACBV;                                                       26936000
   INTEGER LACBV;                                                       26938000
   INTEGER IOQX;                                                        26940000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+18 >>                   26942000
   LOGICAL ACB'FOPTIONS = ACB+6;                                        26944000
   INTEGER ACB'ERROR    = ACB+14;                                       26946000
   INTEGER ACB'FCB      = ACB+26;                                       26948000
   LOGICAL ACB'STATW    = ACB+29;                                       26950000
   INTEGER ACB'AMLD     = ACB+38;                                       26952000
                                                                        26954000
   INTEGER DSTX;       << user's buffer DST >>                          26956000
   << End of LOC'ACB params >>                                          26958000
                                                                        26960000
   INTEGER ARRAY FCB(0:SIZEBFCB-1) = Q;   << Q+75 >>                    26962000
   DOUBLE DFCB = FCB;                                                   26964000
                                                                        26966000
                                                                        26970000
<< **  FREAD/WRITELABEL: Begin execution  ** >>                         26972000
                                                                        26974000
   TOS := 0;     << Read label >>                                       26976000
   GO CONT;                                                             26978000
   HELP;  << dummy call >>                                     <<00117>>26980000
                                                                        26982000
FWRITELABEL:                                                            26984000
   TOS := 1;     << Write label >>                                      26986000
                                                                        26988000
CONT:                                                                   26990000
   CODE := TOS;     << Read/Write code >>                               26992000
                                                                        26994000
$  IF X0 = ON                                                           26996000
   IF MONCALLABLE THEN                                                  26998000
      BEGIN                                                             27000000
      FTITLE("FR/W","LABE","L   ",0D);                                  27002000
      DEBUG                                                             27004000
      END;                                                              27006000
$  IF                                                                   27008000
                                                                        27010000
   ERRORON;                                                             27012000
   CRIT := SETCRITICAL;                                                 27014000
   IF PMAP < %14 THEN                                                   27016000
      BEGIN   << File number or buffer address missing. Boo! >>         27018000
      TOS := ACCVIOL;                                                   27020000
      TOS := CCL;                                                       27022000
      GO EXIT                                                           27024000
      END;                                                              27026000
   IF PMAP.(14:1) THEN      << TCOUNT specified? >>            <<DS.00>>27028000
      BEGIN                                                             27030000
      TOS := TCOUNT;                                           <<DS.00>>27032000
      IF < THEN TOS := -(TOS&ASR(1));                          <<DS.00>>27034000
      TCOUNT := TOS;      << +words >>                         <<DS.00>>27036000
      END ELSE TCOUNT := 128;                                  <<DS.00>>27038000
   LOC'ACB(0,18,FN,UMODE);                                              27040000
   DSTX := TOS;                                                         27042000
   IF < THEN                                                            27044000
      BEGIN     << Invalid file number >>                               27046000
      TOS := INVFN;                                                     27048000
      TOS := CCL;                                                       27050000
      GO EXIT                                                           27052000
      END;                                                              27054000
   IF > THEN                                                            27056000
      BEGIN     << File is $NULL >>                                     27058000
      TOS := 0;   << No error >>                                        27060000
      TOS := IF WRITE THEN CCE ELSE CCG;                                27062000
      GO EXIT                                                           27064000
      END;                                                              27066000
   CASE * FTYPE OF                                                      27068000
   BEGIN                                                                27070000
                                                                        27072000
   BEGIN       << conventional file >>                                  27074000
CONVENTIONAL:                                                  <<HM.00>>27076000
   IF IOQX <> 0 THEN                                                    27078000
      BEGIN        << NO-WAIT I/O pending. >>                           27080000
      TOS := IOPENDING;                                                 27082000
      GO ERREX                                                          27084000
      END;                                                              27086000
   IF FBNDVIOL(@TARGET,TCOUNT,UBND) OR TCOUNT > 128 THEN       <<03059>>27088000
      BEGIN      << Bounds violation >>                                 27090000
      TOS := BNDVIOL;                                          <<DS.00>>27092000
      GO ERREX;                                                         27094000
      END;                                                     <<DS.00>>27096000
   ACCTYPE := ACB'ACCCL;     << access class >>                         27098000
   DTYPE := ACB'DTYPE;       << device type >>                 <<01115>>27100000
   IF NOT PMAP THEN LBL := 0;     << default label nr. >>               27102000
   IF ACCTYPE = DIRACC THEN                                             27104000
      BEGIN       << Disk. >>                                           27106000
      IF ACB'FCB=0 THEN GO ILDEV;     << Foreign disk loses. >>         27108000
      LOCK'CB(0,0,75,ACB'FCB.DSTN,ACB'FCB VTA);                         27110000
      FCBADR := DS1;                                                    27112000
      STKADR := DS3;                                                    27114000
      TOS := SIZEBFCB;                                                  27116000
      MOVE'DS'6;        << get local copy of FCB >>                     27118000
      X := FCB.(2:14);                                                  27120000
      IF BADFCBSIZE THEN FTROUBLE(63);                                  27122000
      TOS := IF WRITE THEN FCBLBL ELSE FCBLBLEOF;  << limit >>          27124000
      IF LOGICAL(TOS) <= LOGICAL(LBL) THEN                              27126000
         BEGIN       << Beyond limit. >>                                27128000
         TOS := EOF;     << Error = EOF >>                              27130000
         TOS := CCG;    << flag EOF >>                                  27132000
         GO RELFCB                                                      27134000
         END;                                                           27136000
      IF WRITE AND (LBL+1) > FCBLBLEOF THEN FCBLBLEOF := LBL+1;         27138000
      TOS := FCBADR;                                                    27140000
      TOS := TOS+16;    << offset of FCBUSERLABEL >>                    27142000
      TOS := STKADR;                                                    27144000
      TOS := TOS+16;                                                    27146000
      TOS := 1;                                                         27148000
      MOVE'DS'5;        << update FCBLBLEOF >>                          27150000
      TOS := 0;         << for LDEV >>                                  27152000
      TOS := DOUBLE(LOGICAL(LBL+1));  << label sector offset >>         27154000
      TOS := FCBEXTSIZE;      << Extent size in sectors >>              27156000
      ASMB(LDIV,STBX; ZROB);                                            27158000
      TOS := STKADR;                                                    27160000
      TOS := FCBADR;                                                    27162000
      TOS := TOS+SIZEBFCB+X+X;                                          27164000
      TOS := 2;                                                         27166000
      MOVE'DS'5;         << fetch E-map entry >>                        27168000
      TOS := TOS+DFCB;   << add it to label index >>                    27170000
      TOS := TOS&TASL(8)&DLSR(8);    << separate LDEV >>                27172000
      DISKADR := TOS;       << user label sector nr. >>                 27174000
      LDEV := TOS;         << user label LDEV >>                        27176000
      TOS := ATTACHIO(LDEV,0,DSTX,@TARGET,CODE,TCOUNT,                  27178000
         P1,P2,BFLAGS);    << read or write user label >>               27180000
      DEL;                                                              27182000
      IF TOS.(8:8) <> 1 THEN                                            27184000
         BEGIN       << ATTACHIO reports error. >>                      27186000
         TOS := INVOP;                                                  27188000
         TOS := CCL;                                                    27190000
         GO RELFCB                                                      27192000
         END;                                                           27194000
                                                                        27196000
      <<* * * Measurement data on Disk FREAD/WRITELABEL * * *>>         27198000
                                                                        27200000
$  IF X3 = ON                                                           27202000
      IF MEAS'TAPE'ON THEN BEGIN                                        27204000
      MMSTAT(IF READ THEN EFREADLABEL ELSE EFWRITELABEL,                27206000
         FN,TCOUNT,0);     << record measurement >>                     27208000
      END; << OF MEAS'TAPE'ON>>                                         27210000
$  IF                                                                   27212000
                                                                        27214000
      TOS := 0;    << No error >>                                       27216000
      TOS := CCE;  << OK condition code >>                              27218000
RELFCB:                                                                 27220000
      UNLOCK'CB(0,ACB'FCB.DSTN,ACB'FCB VTA);                            27222000
      END      << disk >>                                               27224000
                                                                        27226000
   ELSE IF LABEL'DEVICE THEN                                   <<03582>>27228000
      BEGIN         << Labeled tape >>                                  27230000
      IF NOT PMAP.(14:1) THEN TCOUNT := 40;                    <<02545>>27232000
      IF TCOUNT <> 40 THEN                                              27234000
         BEGIN    << Wrong size for label. >>                           27236000
         TOS := BNDVIOL;                                                27238000
         GO ERREX;                                                      27240000
         END;                                                           27242000
      LDEV := ACB'DADDR;                                                27244000
      IF WRITE THEN                                            <<02545>>27248000
         BEGIN       << FWRITELABEL >>                         <<02545>>27250000
         IF ACBACTYPE = 0 THEN GO ACV;  << read-only. >>       <<02545>>27252000
         TOS := CHECKUL(FN,3,0);                               <<02545>>27254000
         IF < THEN GO ERREX;                                   <<02545>>27256000
         DEL;                                                  <<02545>>27258000
         ATTACHIO(LDEV,0,DSTX,@TARGET,1,                       <<02545>>27260000
            TCOUNT,0,4,BFLAGS);    << write label >>           <<02693>>27262000
         END                                                   <<02545>>27264000
      ELSE                                                     <<02545>>27266000
         BEGIN        << FREADLABEL >>                         <<02545>>27268000
         IF ACBACTYPE <> 0 THEN                                <<02545>>27270000
            BEGIN     << write-access - can't read. >>         <<02545>>27272000
ACV:        TOS := ACCVIOL;                                    <<02545>>27274000
            GO ERREX;                                          <<02545>>27276000
            END;                                               <<02545>>27278000
         IF LBL < 0 AND NOT PRIVMODE THEN                      <<02693>>27280000
            BEGIN   << Must have PRIV for hdr/trlr labels >>   <<02693>>27282000
            TOS := PRIVVIOL;                                   <<02693>>27284000
            GO ERREX;                                          <<02693>>27286000
            END;                                               <<02693>>27288000
         TOS := CHECKUL(FN,2,LBL);      << position >>         <<02693>>27290000
         IF < THEN GO ERREX;                                   <<02545>>27292000
         DEL;                                                  <<02545>>27294000
         TOS := ATTACHIO(LDEV,0,DSTX,@TARGET,0,                <<02545>>27296000
            TCOUNT,0,0,BFLAGS);    << read label >>            <<02545>>27298000
         DEL;                                                           27300000
         IF TOS.(8:8) = EOFSTAT THEN                                    27302000
            BEGIN         << EOF; BSR over it >>               <<02545>>27304000
            ATTACHIO(LDEV,0,0,0,12,0,0,0,BFLAGS);              <<02545>>27306000
            TOS := 0;      << No error >>                               27308000
            TOS := CCG;    << Report EOF >>                             27310000
            GO RELACB;                                                  27312000
            END;    << EOF >>                                           27314000
         END;                                                  <<02545>>27316000
      TOS := 0;     << No error >>                                      27320000
      TOS := CCE;  << OK condition code >>                              27322000
      END         << labeled tape >>                                    27324000
   ELSE                                                                 27326000
      BEGIN                                                             27328000
ILDEV:TOS := DEVVIOL;      << other devices lose. >>                    27330000
ERREX:                                                                  27332000
      TOS := CCL;                                                       27334000
      END;                                                              27336000
                                                                        27338000
RELACB:                                                                 27340000
   ACB'ERROR := S1;                                                     27342000
   UNLOC'ACB(18,0);    << release ACB >>                                27344000
   END;      << conventional file >>                                    27346000
                                                                        27348000
   BEGIN   << Remote file >>                                            27350000
   IF FBNDVIOL(@TARGET,TCOUNT,UBND) OR TCOUNT > 128 THEN       <<03059>>27352000
      BEGIN                                                             27354000
      TOS := CCL;                                                       27356000
      GO EXIT                                                           27358000
      END;                                                              27360000
   DSTX := EXCHANGEDB(0);   << set DB to stack >>              <<DS.00>>27362000
   ALLOCRFABUF;                                                <<DS.00>>27364000
   RFALEN := 7;                                                <<DS.00>>27366000
   TOS := "RFA ";                                              <<DS.00>>27368000
   TOS := 8;    << assume FREADLABEL >>                        <<DS.00>>27370000
   IF WRITE THEN TOS := TOS+1;   << WRITELABEL >>              <<DS.00>>27372000
   TOS := RFAFILE;                                             <<DS.00>>27374000
   TOS := TCOUNT;                                              <<DS.00>>27376000
   IF = THEN                                                            27378000
      BEGIN                                                             27380000
      TOS := 0;     << no error >>                                      27382000
      TOS := CCE;                                                       27384000
      GO EXIT                                                           27386000
      END;                                                              27388000
   TOS := LBL;                                                 <<DS.00>>27390000
   TOS := PMAP;                                                <<DS.00>>27392000
   IF WRITE THEN                                               <<DS.00>>27394000
      BEGIN                                                    <<DS.00>>27396000
      RFALEN := RFALEN+TCOUNT;                                 <<DS.00>>27398000
      TOS := TCOUNT;  << copy label to stack >>                <<DS.00>>27400000
      ASMB(ADDS 0);                                            <<DS.00>>27402000
      IF DSTX = 0 THEN                                         <<DS.00>>27404000
         MOVE RFAPTR(7) := TARGET,(TCOUNT)                     <<DS.00>>27406000
      ELSE                                                     <<DS.00>>27408000
         BEGIN   << User buffer is in XDS. >>                  <<DS.00>>27410000
         TOS := @RFAPTR(7);                                    <<DS.00>>27412000
         TOS := DSTX;                                          <<DS.00>>27414000
         TOS := @TARGET;                                       <<DS.00>>27416000
         TOS := TCOUNT;                                        <<DS.00>>27418000
         ASMB(MFDS 4);                                         <<DS.00>>27420000
         END                                                   <<DS.00>>27422000
      END                                                      <<DS.00>>27424000
   ELSE                                                                 27426000
      BEGIN     << Read >>                                     <<DS.00>>27428000
      TOS := TCOUNT-RFALEN+1;                                  <<DS.00>>27430000
      ASMB(ADDS 0);   << Leave space for return label >>       <<DS.00>>27432000
      END;                                                     <<DS.00>>27434000
   MWCNOBUF;                                                   <<DS.00>>27436000
   CHECKXFER;                                                  <<DS.00>>27438000
   IF WRITE THEN                                               <<DS.00>>27440000
      BEGIN                                                    <<DS.00>>27442000
      DELAPPENDAGE;                                            <<DS.00>>27444000
      END                                                      <<DS.00>>27446000
   ELSE      << Read >>                                                 27448000
      BEGIN    << Move label to user >>                        <<DS.00>>27450000
      IF RFAPTR.CC = CCE THEN                                  <<DS.00>>27452000
      IF DSTX = 0 THEN                                         <<DS.00>>27454000
         MOVE TARGET := RFAPTR(1),(TCOUNT)                     <<DS.00>>27456000
      ELSE                                                     <<DS.00>>27458000
         BEGIN   << User buffer in XDS. >>                     <<DS.00>>27460000
         TOS := DSTX;                                          <<DS.00>>27462000
         TOS := @TARGET;                                       <<DS.00>>27464000
         TOS := @RFAPTR(1);                                    <<DS.00>>27466000
         TOS := TCOUNT;                                        <<DS.00>>27468000
         ASMB(MTDS 4);                                         <<DS.00>>27470000
         END;                                                  <<DS.00>>27472000
      TOS := TCOUNT;                                           <<DS.00>>27474000
      ASMB(SUBS 0);   << delete appendage >>                   <<DS.00>>27476000
      END;                                                     <<DS.00>>27478000
   IF DSTX <> 0 THEN                                           <<DS.00>>27480000
      DSTX := EXCHANGEDB(DSTX);                                <<DS.00>>27482000
   PREPRETURN;                                                 <<DS.00>>27484000
   END;    << remote file >>                                            27486000
                                                                        27488000
      << dummy 2 >>;                                                    27490000
      << dummy 3 >>;                                                    27492000
      << dummy 4 >>;                                                    27494000
      << dummy 5 >>;                                                    27496000
   BEGIN   << KSAM file >>                                              27498000
   IF FBNDVIOL(@TARGET,TCOUNT,UBND) OR TCOUNT > 128 THEN       <<03059>>27500000
      BEGIN   << Bounds violation >>                                    27502000
      FKSAMBNDVIOL(FN);                                        <<KS.00>>27504000
      TOS := BNDVIOL;                                          <<DS.00>>27506000
      TOS := CCL;                                              <<DS.00>>27508000
      GO EXIT;                                                 <<DS.00>>27510000
      END;                                                     <<DS.00>>27512000
   IF READ THEN                                                <<KS.00>>27514000
      KREADLABEL(FN,TARGET,TCOUNT,LBL)                         <<KS.00>>27516000
   ELSE                                                        <<KS.00>>27518000
      KWRITELABEL(FN,TARGET,TCOUNT,LBL);                       <<KS.00>>27520000
   PUSH(STATUS);                                               <<KS.00>>27522000
   TOS := TOS.CC;     << condition code to report >>           <<KS.00>>27524000
   ASMB(ZERO,XCH);                                             <<KS.00>>27526000
   END;    << KSAM file >>                                     <<KS.00>>27528000
   <<DUMMY 7>>;                                                <<HM.00>>27530000
   GO CONVENTIONAL;                                            <<HM.00>>27532000
   END; << FTYPE CASE >>                                       <<DS.00>>27534000
                                                                        27536000
EXIT:                                                                   27538000
   CONDCODE := TOS;                                                     27540000
   RESETCRITICAL(CRIT);                                                 27542000
   ERROREXIT(5,S0,0)                                                    27544000
   END;    << procedure FREAD/FWRITELABEL >>                            27546000
$PAGE " FLOCK, FUNLOCK "                                                27548000
$CONTROL SEGMENT = FILESYS3   << FLOCK >>                               27550000
PROCEDURE FLOCK(FILENUM,T);                                             27552000
VALUE FILENUM,T;                                                        27554000
INTEGER FILENUM;                                                        27556000
LOGICAL T;                                                              27558000
OPTION PRIVILEGED;                                                      27560000
   BEGIN                                                                27562000
   INTEGER CODE,ERROR'NUM := 0;                                <<04559>>27564000
   INTEGER CRIT;      << for SETCRITICAL >>                             27566000
   DOUBLE FCBWORDS;                                                     27568000
      INTEGER FCB'RIN = FCBWORDS;                                       27570000
                                                                        27572000
<< Remote file access (RFA) variables: >>                               27574000
                                                                        27576000
   INTEGER POINTER RFAPTR;  << appendage pointer >>            <<DS.00>>27578000
   INTEGER RFALEN;          << appendage length >>             <<DS.00>>27580000
                                                                        27582000
<< Following LOC'ACB params must be last and in order: >>               27584000
   INTEGER ACBMQ;      << Q-relative displacement of ACB >>    <<04559>>27586000
   INTEGER AFTE;                                                        27588000
   INTEGER PACBV;                                                       27590000
   INTEGER LACBV;                                                       27592000
   INTEGER IOQX;                                                        27594000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<04559>>27596000
   INTEGER ACB'FCB      = ACB+26;                                       27598000
   INTEGER ACB'STATW    = ACB+29;                              <<01672>>27600000
   INTEGER DSTX;       << user's buffer DST >>                          27602000
   << End of LOC'ACB params >>                                          27604000
                                                                        27606000
   ENTRY KSLOCK;   << for KSAM'S KCLOSE procedure >>           <<Y1.03>>27608000
   CODE := 0;                                                           27610000
   GO TO CONTINUE;                                             <<Y1.03>>27612000
                                                                        27614000
KSLOCK:            << KSAM entry point >>                      <<Y1.03>>27616000
   CODE := 1;                                                           27618000
CONTINUE:                                                      <<Y1.03>>27620000
                                                                        27622000
$  IF X0 = ON                                                           27624000
   IF MONCALLABLE THEN                                                  27626000
      BEGIN                                                             27628000
      FTITLE("FLOC","K   ",0D,0D);                                      27630000
      DEBUG                                                             27632000
      END;                                                              27634000
$  IF                                                                   27636000
                                                                        27638000
   ERRORON;                                                             27640000
   CRIT := SETCRITICAL;                                                 27642000
   GET'ACB'Q'LOC;                                              <<04559>>27644000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<01672>>27646000
   IF < THEN                                                            27648000
      BEGIN         << Invalid file nr. >>                              27650000
      TOS := INVFN;                                                     27652000
      TOS := CCL;                                                       27654000
      GO EXIT                                                           27656000
      END;                                                              27658000
   IF > THEN                                                            27660000
      BEGIN         << File is $NULL >>                                 27662000
      TOS := 0;     << no error >>                                      27664000
      TOS := CCE;                                                       27666000
      GO EXIT                                                           27668000
      END;                                                              27670000
   CASE * FTYPE OF                                                      27672000
   BEGIN                                                                27674000
                                                                        27676000
   BEGIN     << Conventional file >>                                    27678000
CONVENTIONAL:                                                  <<HM.00>>27680000
                                                               <<04559>>27682000
   IF ACB'ACCCL <> DIRACC THEN                                 <<04559>>27684000
      ERROR'NUM := ACCVIOL    << Must be a disc file.       >> <<04559>>27686000
   ELSE                                                        <<04559>>27688000
      BEGIN                                                    <<04559>>27690000
      FCBWORDS := GETFCB'INFO(ACB'FCB,7);  << Get RIN #     >> <<04559>>27692000
      IF FCB'RIN = 0 THEN                                      <<04559>>27694000
         ERROR'NUM := ACCVIOL << No RIN, not opened for lock>> <<04559>>27696000
      ELSE IF NOT MRCAPOK(TRUE,FCB'RIN) AND CODE = 0 THEN      <<04559>>27698000
         ERROR'NUM := MRIN;   << Program not prepped w/ MR  >> <<04559>>27700000
      END;                                                     <<04559>>27702000
                                                               <<04559>>27704000
   ACBERROR := ERROR'NUM;                                      <<04559>>27706000
   UNLOC'ACB(ACBMQ,0);        << Unlock before impeding.    >> <<04559>>27708000
                                                               <<04559>>27710000
   IF ERROR'NUM <> 0 THEN                                      <<04559>>27712000
      BEGIN                                                    <<04559>>27714000
      TOS := ERROR'NUM;       << Set ERROREXIT parameter.   >> <<04559>>27716000
      TOS := CCL;             << Set CC for ERROREXIT       >> <<04559>>27718000
      END                                                      <<04559>>27720000
   ELSE                                                        <<04559>>27722000
      BEGIN                                                    <<04559>>27724000
      RLOCK(FCB'RIN,T);       << Lock that there RIN!       >> <<04559>>27726000
      IF < THEN                                                <<04559>>27728000
         BEGIN                                                 <<04559>>27730000
         MRCAPOK(FALSE);      << Reset Global RIN flag.     >> <<04559>>27732000
         TOS := ERROR'NUM;                                     <<04559>>27734000
         TOS := CCG;          << Signify can't get RIN.     >> <<04559>>27736000
         END                                                   <<04559>>27738000
      ELSE     << We have RIN locked.  Re-locate ACB for    >> <<04559>>27740000
         BEGIN << FQUIESCE'IO.                              >> <<04559>>27742000
         LOC'ACB(DSTX,ACBMQ,FILENUM,UMODE);                    <<04559>>27744000
         DEL;                 << Delete DSTX return parm.   >> <<04559>>27746000
         IF NOT ACBINHIBITBUF                                  <<04559>>27748000
            THEN FQUIESCE'IO(0); << Clear buffers           >> <<04559>>27750000
         UNLOC'ACB(ACBMQ,0);                                   <<04559>>27752000
         TOS := ERROR'NUM;    << Report no error.           >> <<04559>>27754000
         TOS := CCE;                                           <<04559>>27756000
         END;                                                  <<04559>>27758000
      END;                                                     <<04559>>27760000
                                                               <<04559>>27762000
   <<* * * Measurement data on FLOCK * * *>>                   <<04559>>27764000
                                                               <<04559>>27766000
$  IF X3 = ON                                                  <<04559>>27768000
   IF MEAS'TAPE'ON AND ERROR'NUM = 0 THEN BEGIN                <<04559>>27770000
   IF ACBACCCL = DIRACC THEN  << measure? >>                   <<04559>>27772000
      MMSTAT(EFLOCK,FILENUM,T,S0);                             <<04559>>27774000
   END; << OF MEAS'TAPE'ON>>                                   <<04559>>27776000
$  IF                                                          <<04559>>27778000
                                                               <<04559>>27780000
   END;    << conventional file >>                                      27782000
                                                                        27784000
   BEGIN   << Remote file >>                                            27786000
   IF NOT MRCAPOK(TRUE) THEN    << Prevent illegal locking       DS.2F>>27788000
      BEGIN                     << of multiple RINs across       DS.2F>>27790000
      TOS := MRIN;              << systems.                      DS.2F>>27792000
      TOS := CCL;                                              <<DS.2F>>27794000
      GO EXIT;                                                 <<DS.2F>>27796000
      END;                                                     <<DS.2F>>27798000
   SETRFAPTR;                                                  <<DS.00>>27800000
   RFALEN := 7;                                                <<DS.03>>27802000
   TOS := "RFA ";                                              <<DS.00>>27804000
   TOS := 19;                                                  <<DS.00>>27806000
   TOS := RFAFILE;                                             <<DS.00>>27808000
   TOS := T;                                                   <<DS.00>>27810000
   TOS := 0D;                                                           27812000
   MWCNOBUF;                                                   <<DS.00>>27814000
   CHECKXFER;                                                  <<DS.00>>27816000
   DDEL; DDEL;                                                 <<DS.03>>27818000
   DDEL;                                                                27820000
   PREPRETURN;                                                 <<DS.00>>27822000
   IF S0 = CCL THEN                                            <<DS.2F>>27824000
       MRCAPOK( FALSE );                                       <<DS.2F>>27826000
   END;   << remote file >>                                             27828000
                                                                        27830000
      << dummy 2 >>;                                                    27832000
      << dummy 3 >>;                                                    27834000
      << dummy 4 >>;                                                    27836000
      << dummy 5 >>;                                                    27838000
   BEGIN   << KSAM file >>                                              27840000
   KLOCK(FILENUM,T);                                           <<KS.00>>27842000
   PUSH(STATUS);                                               <<KS.00>>27844000
   TOS := TOS.CC;     << report condition code >>              <<KS.00>>27846000
   ASMB(ZERO,XCH);                                             <<KS.00>>27848000
   END;    << KSAM file >>                                     <<KS.00>>27850000
   <<DUMMY 7>>;                                                <<HM.00>>27852000
   GO CONVENTIONAL;                                            <<HM.00>>27854000
   END;     << FTYPE CASE >>                                   <<DS.00>>27856000
                                                                        27858000
EXIT:                                                                   27860000
   CONDCODE := TOS;  << report condition code >>                        27862000
   RESETCRITICAL(CRIT);                                                 27864000
   ERROREXIT(2,S0,0)                                                    27866000
   END;     << procedure FLOCK >>                                       27868000
$CONTROL SEGMENT = FILESYS3   << FUNLOCK >>                             27870000
PROCEDURE FUNLOCK(FILENUM);                                             27872000
VALUE FILENUM;                                                          27874000
INTEGER FILENUM;                                                        27876000
OPTION PRIVILEGED;                                                      27878000
   BEGIN                                                                27880000
   INTEGER CRIT;     << for SETCRITICAL >>                              27882000
   DOUBLE FCBWORDS;                                                     27884000
      INTEGER FCB'RIN = FCBWORDS;                                       27886000
                                                                        27888000
   << Remote file access (RFA) variables: >>                            27890000
                                                                        27892000
   INTEGER POINTER RFAPTR;   << appendage pointer >>                    27894000
   INTEGER RFALEN;           << appendage length >>                     27896000
                                                                        27898000
<< Following LOC'ACB params must be last and in order: >>               27900000
   INTEGER ACBMQ;      << Q-relative displacement of ACB >>    <<04591>>27902000
   INTEGER AFTE;                                                        27904000
   INTEGER PACBV;                                                       27906000
   INTEGER LACBV;                                                       27908000
   INTEGER IOQX;                                                        27910000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q + ACBMQ >>     <<04591>>27912000
   INTEGER ACB'FCB      = ACB+26;                                       27914000
   INTEGER ACB'STATW    = ACB+29;                              <<01672>>27916000
   INTEGER DSTX;       << user's buffer DST >>                          27918000
   << End of LOC'ACB params >>                                          27920000
                                                                        27922000
$  IF X0 = ON                                                           27924000
   IF MONCALLABLE THEN                                                  27926000
      BEGIN                                                             27928000
      FTITLE("FUNL","OCK ",0D,0D);                                      27930000
      DEBUG                                                             27932000
      END;                                                              27934000
$  IF                                                                   27936000
                                                                        27938000
   ERRORON;                                                             27940000
   CRIT := SETCRITICAL;                                                 27942000
   GET'ACB'Q'LOC;                                              <<04591>>27944000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<01672>>27946000
   IF > THEN                                                            27948000
      BEGIN       << File is $NULL >>                                   27950000
      TOS := 0;   << No error >>                                        27952000
      TOS := CCE;                                                       27954000
      GO EXIT                                                           27956000
      END;                                                              27958000
   IF < THEN                                                            27960000
      BEGIN       << Invalid file number >>                             27962000
      TOS := INVFN;                                                     27964000
      TOS := CCL;                                                       27966000
      GO EXIT                                                           27968000
      END;                                                              27970000
   CASE * FTYPE OF                                                      27972000
   BEGIN                                                                27974000
                                                                        27976000
   BEGIN     << Conventional file >>                                    27978000
CONVENTIONAL:                                                  <<HM.00>>27980000
   IF ACB'ACCCL <> DIRACC THEN GO VILE;   << must be disk >>   <<01672>>27982000
   FCBWORDS := GETFCB'INFO(ACB'FCB,7);  << Get RIN nr. from FCB >>      27984000
   IF FCB'RIN = 0 THEN                                                  27986000
      BEGIN    << No RIN - wasn't FOPENed for locking. >>               27988000
VILE: TOS := ACCVIOL;                                          <<01672>>27990000
      TOS := CCL;                                                       27992000
      GO UNLK;                                                          27994000
      END;                                                              27996000
   IF NOT ACBINHIBITBUF THEN FQUIESCE'IO(0);  << empty buffers >>       27998000
   RUNLOCK(FCB'RIN);                                                    28000000
   PUSH(STATUS);                                                        28002000
   TOS := TOS.(6:2);          << report condition code >>      <<02354>>28004000
   IF = THEN TOS:=NOTLOCKED   << CCG (=0)  : file not locked >><<02354>>28006000
   ELSE IF S0 = CCE THEN      << CCE (=2)  : unlock OK       >><<02354>>28008000
           BEGIN                                               <<02354>>28010000
           MRCAPOK(FALSE);    << reset Global RIN flag >>      <<02354>>28012000
           TOS:=0;            << No error >>                   <<02354>>28014000
           END                                                 <<02354>>28016000
        ELSE TOS:=NORIN;      << CCL: Rin not allocated >>     <<02354>>28018000
   ASMB(XCH);                 << S-1: error #; S-0: CC >>      <<02354>>28020000
                                                               <<02354>>28022000
   <<* * * Measurement data on FUNLOCK * * *>>                          28024000
                                                                        28026000
$  IF X3 = ON                                                           28028000
   IF MEAS'TAPE'ON THEN BEGIN                                           28030000
   IF S0 = CCE AND ACBACCCL = DIRACC THEN                               28032000
      MMSTAT(EFUNLOCK,FILENUM,0,0);                                     28034000
   END; << OF MEAS'TAPE'ON>>                                            28036000
$  IF                                                                   28038000
                                                                        28040000
                                                                        28042000
UNLK:                                                                   28044000
   ACBERROR := S1;                                                      28046000
   UNLOC'ACB(ACBMQ,0);     << Release ACB >>                   <<01672>>28048000
   END;   << conventional file >>                                       28050000
                                                                        28052000
   BEGIN     << Remote file >>                                 <<DS.00>>28054000
   SETRFAPTR;                                                  <<DS.00>>28056000
   RFALEN := 6;                                                <<DS.03>>28058000
   TOS := "RFA ";                                              <<DS.00>>28060000
   TOS := 20;                                                  <<DS.00>>28062000
   TOS := RFAFILE;                                             <<DS.00>>28064000
   TOS := 0D;                                                           28066000
   MWCNOBUF;                                                   <<DS.00>>28068000
   CHECKXFER;                                                  <<DS.00>>28070000
   DELAPPENDAGE;                                               <<DS.00>>28072000
   PREPRETURN;                                                 <<DS.00>>28074000
   IF S0 = CCE THEN                                            <<DS.2F>>28076000
       MRCAPOK( FALSE );                                       <<DS.2F>>28078000
   END;   << Remote file >>                                             28080000
                                                                        28082000
      << dummy 2 >>;                                                    28084000
      << dummy 3 >>;                                                    28086000
      << dummy 4 >>;                                                    28088000
      << dummy 5 >>;                                                    28090000
   BEGIN     << KSAM file >>                                   <<KS.00>>28092000
   KUNLOCK(FILENUM);                                           <<KS.00>>28094000
   PUSH(STATUS);                                               <<KS.00>>28096000
   TOS := TOS.CC;                                              <<KS.00>>28098000
   ASMB(ZERO,XCH);                                             <<KS.00>>28100000
   END;   << KSAM file >>                                      <<KS.00>>28102000
   <<DUMMY 7>>;                                                <<HM.00>>28104000
   GO CONVENTIONAL;  <<MSG FILE>>                              <<HM.00>>28106000
   END;     << FTYPE CASE >>                                            28108000
EXIT:                                                                   28110000
   CONDCODE := TOS;    << report condition code >>                      28112000
   RESETCRITICAL(CRIT);                                                 28114000
   ERROREXIT(1,S0,0)                                                    28116000
   END;     << procedure FUNLOCK >>                                     28118000
$PAGE " FALTSEC "                                                       28120000
$CONTROL SEGMENT = FILESYS3                                             28122000
   PROCEDURE FALTSEC(FILENUM,NEWSECUREFLAG,NEWMATRIX,                   28124000
                     OLDFLAG,OLDMATRIX,EXCOND);                         28126000
      << Must be called with DB at the stack.  >>                       28128000
   VALUE FILENUM;                                                       28130000
   LOGICAL NEWSECUREFLAG;                                               28132000
   INTEGER FILENUM,OLDFLAG,EXCOND;                                      28134000
   ARRAY NEWMATRIX,OLDMATRIX;                                           28136000
   OPTION PRIVILEGED,VARIABLE;                                          28138000
   BEGIN                                                                28140000
                                                                        28142000
<<                                                                      28144000
This procedure allows the caller to                                     28146000
          - release an open file ('RELEASE')                            28148000
          - secure an open file  ('SECURE')                             28150000
          - alter the security mask of an open file ('ALTSEC').         28152000
                                                                        28154000
                                                                        28156000
INPUT:                                                                  28158000
       FILENUM        - File number of currently open file              28160000
                        *** REQUIRED PARAMETER ***                      28162000
                                                                        28164000
       NEWSECUREFLAG  - Optional integer variable.  If present,         28166000
                        requests FALTSEC to set the secure flag bit     28168000
                        in the file label to either secure the file     28170000
                        (if NEWSECUREFLAG is 1) or release the file     28172000
                        (NEWSECUREFLAG is 0)                            28174000
                                                                        28176000
       NEWMATRIX      - Optional two word array containing the new      28178000
                        security information as follows:                28180000
                                                                        28182000
                                                                        28184000
WORD 0:                                                                 28186000
------                                                                  28188000
                                                                        28190000
  0    1   2   3   4   5   6   7   8   9   10  11  12  13  14  15       28192000
|____|____|___|___|___|___|___|___|___|___|___|___|___|___|___|___|     28194000
|    |    |   |   |   |   |   |   |   |   |   |   |   |   |   |   |     28196000
|Def-|Cre-|R  |R  |R  |R  |R  |R  |A  |A  |A  |A  |A  |A  |W  |W  |     28198000
|ault|ator|   |   |   |   |   |   |   |   |   |   |   |   |   |   |     28200000
|Sec |Sec |ANY|AC |AL |GU |GL |CR |ANY|AC |AL |GU |GL |CR |ANY|AC |     28202000
|____|____|___|___|___|___|___|___|___|___|___|___|___|___|___|___|     28204000
                                                                        28206000
                                                                        28208000
                                                                        28210000
WORD 1:                                                                 28212000
------                                                                  28214000
                                                                        28216000
  0    1   2   3   4   5   6   7   8   9   10  11  12  13  14  15       28218000
|____|____|___|___|___|___|___|___|___|___|___|___|___|___|___|___|     28220000
|    |    |   |   |   |   |   |   |   |   |   |   |   |   |   |   |     28222000
| W  | W  |W  |W  |L  |L  |L  |L  |L  |L  |X  |X  |X  |X  |X  |X  |     28224000
|    |    |   |   |   |   |   |   |   |   |   |   |   |   |   |   |     28226000
| AL | GU |GL |CR |ANY|AC |AL |GU |GL |CR |ANY|AC |AL |GU |GL |CR |     28228000
|____|____|___|___|___|___|___|___|___|___|___|___|___|___|___|___|     28230000
                                                                        28232000
                                                                        28234000
WORD 0:                                                                 28236000
------                                                                  28238000
        .(0:1) - if set to 1, set default security (R,A,W,L,X:ANY)      28240000
        .(1:1) - if set to 1, set security to creator-only              28242000
                              (R,A,W,L,X:CR)                            28244000
                 NOTE: If both bits 0 and 1 are set, the creator-only   28246000
                       option will take precedence.                     28248000
                                                                        28250000
                       If neither of the bits is set, the matrix will   28252000
                       be set according to the remaining bits for the   28254000
                       matrix (word 0.(2:14) and word 1).  However,     28256000
                       if all the remaining bits are zero, no change    28258000
                       to the security matrix will be made (CCG will    28260000
                       be returned).                                    28262000
                                                                        28264000
       .(2:14) - Each bit represents access for a given user type.      28266000
                 Bit set to 1 enables security mode                     28268000
                 Bit set to 0 disables mode                             28270000
                                                                        28272000
                 R: Read         ANY: Any user                          28274000
                 A: Append       AC : Account member                    28276000
                 W: Write        AL : Account librarian                 28278000
                 L: Lock         GU : Group user                        28280000
                 X: Execute      GL : Group librarian                   28282000
                                 CR : Creator                           28284000
                                                                        28286000
WORD 1:                                                                 28288000
------                                                                  28290000
       .(0:16) - Same rules as for word 0 (2:14).                       28292000
                                                                        28294000
                                                                        28296000
                                                                        28298000
                                                                        28300000
**Note:  if all bits are off (word 0 (2:14) and word 1 (0:16))          28302000
         then no change will be made to security matrix.                28304000
         Also, if either default or creator-only security is            28306000
         selected, word 0.(2:14) and word 1 will be ignored.            28308000
                                                                        28310000
OUTPUT:                                                                 28312000
        OLDFLAG         - Optional integer variable.  If present,       28314000
                          FALTSEC will return the file label            28316000
                          secure flag setting (0=released,              28318000
                          1=secured) prior to any change made by        28320000
                          FALTSEC.                                      28322000
                                                                        28324000
        OLDMATRIX       - Optional two word array. If present, FALTSEC  28326000
                          will return the security information as set   28328000
                          in the file label prior to change made (if    28330000
                          any) by this call to FALTSEC.  (Same format   28332000
                          as 'NEWMATRIX' except that the first 2 bits   28334000
                          (word 0.(0:2)) are not used.)                 28336000
                                                                        28338000
                                                                        28340000
        EXCOND          - Optional integer variable.  If present,       28342000
                          and an exceptional condition occurs,          28344000
                          FALTSEC will return a number indicating       28346000
                          the nature of the exceptional condition:      28348000
                                                                        28350000
                          1:    Caller requested 'secure' but file      28352000
                                was already secured;                    28354000
                                                                        28356000
                          2:    Caller requested 'release' but file     28358000
                                was already released;                   28360000
                                                                        28362000
                          3:    Caller only requested a change to       28364000
                                the security matrix but the file        28366000
                                is currently released: matrix           28368000
                                changed as requested.                   28370000
                                                                        28372000
                          4:    'NEWMATRIX' passed by caller has        28374000
                                all zero bits; no change to security    28376000
                                was made by FALTSEC;                    28378000
                                                                        28380000
                          5:    Both the default and creator-only       28382000
                                bits were set (word 0, bits 0 and 1)    28384000
                                in the 'NEWMATRIX'; creator-only bit    28386000
                                used.                                   28388000
                                                                        28390000
                          In the event that more than one exception     28392000
                          occurs, the most serious (generally with      28394000
                          the highest number) is returned.              28396000
                                                                        28398000
        Condition code  - CCL, CCE, CCG returned as described below.    28400000
                                                                        28402000
                  CCL: An error occurred; no change was made.           28404000
                       Use FCHECK to determine the error number.        28406000
                                                                        28408000
                       An error will be returned if                     28410000
                       - DB is not set to stack              ILLDB      28412000
                       - file number is invalid or omitted   INVFN      28414000
                       - the file is not a disc file         DEVVIOL    28416000
                         or it is a spoolfile                           28418000
                       - the file is not opened exclusively  MLTIACCERR 28420000
                       - the user is not the creator         USERIDVIOL 28422000
                       - a file label IO error occurs.       LBLIOERR   28424000
                                                                        28426000
                  CCE: Change successfully made (no error).             28428000
                                                                        28430000
                  CCG: An exceptional condition occurred;               28432000
                       change was made where applicable.                28434000
                                                                        28436000
                       Examples of possible exceptional                 28438000
                       conditions are listed above (see                 28440000
                       EXCOND).                                         28442000
                                                                        28444000
                                                                        28446000
>>                                                                      28448000
   LOGICAL PARM=Q-4;                                                    28450000
   INTEGER CC';  << for condition code >>                               28452000
                                                                        28454000
   DEFINE                                                               28456000
                                                                        28458000
   NOFILENUM=PARM.(10:2)=0#,                                            28460000
   CHANGE'SECURITY=PARM.(11:2)<>0#,                                     28462000
                                                                        28464000
   SET'SECUREFLAG=PARM.(11:1)#,                                         28466000
   SET'MATRIX=PARM.(12:1)#,                                             28468000
   SELECT'MATRIX=TOS.(0:2)#,  << Word 0 of NEWMATRIX, bits 0 and 1 >>   28470000
                                                                        28472000
   RTN'OLDFLAG=PARM.(13:1)#,                                            28474000
   RTN'OLDMATRIX=PARM.(14:1)#,                                          28476000
   SET'EXCOND=PARM.(15:1)#,                                             28478000
   FILE'SECURED=LOGICAL(FLSECURE)#;                                     28480000
                                                                        28482000
   EQUATE R=6,AP=R,W=R,L=R,EX=R,                                        28484000
          CR=1,   << Bits 000001 >>                                     28486000
          ANY=32; << Bits 100000 >>                                     28488000
                                                                        28490000
   DOUBLE DEFAULTMATRIX:=[R/ANY,AP/ANY,W/ANY,L/ANY,EX/ANY]D,            28492000
          CREATORMATRIX:=[R/CR,AP/CR,W/CR,L/CR,EX/CR]D;                 28494000
                                                                        28496000
   DOUBLE POINTER NEWMATRIXDBL=NEWMATRIX,                               28498000
                  OLDMATRIXDBL=OLDMATRIX;                               28500000
                                                                        28502000
   INTEGER CRIT;        << for SETCRITICAL>>                            28504000
   INTEGER POINTER PCBX;  <<PCBX POINTER>>                              28506000
   INTEGER A := -1;    << for GETSIR >>                                 28508000
   INTEGER DADDR;                                                       28510000
                                                                        28512000
   << ACB parameters must be in order: >>                               28514000
                                                                        28516000
   INTEGER AFTE;        << AFT entry word 0 >>                          28518000
   INTEGER PACBV;       << physical ACB vector >>                       28520000
   INTEGER LACBV;       << logical ACB vector >>                        28522000
   INTEGER IOQX;                                                        28524000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;                                 28526000
   BUILD'ACB;                                                           28528000
   LOGICAL DSTX;        << User's DST nr. >>                            28530000
                                                                        28532000
   << File label parameters >>                                          28534000
                                                                        28536000
   DOUBLE LABADR;      << file label sector nr. >>                      28538000
   INTEGER ARRAY FLAB(0:127);  << file label buffer >>                  28540000
   DOUBLE POINTER FLABDBL = FLAB;                                       28542000
   BYTE POINTER CREATOR := @FLUSERID;                                   28544000
                                                                        28546000
   << JIT info >>                                                       28548000
                                                                        28550000
   INTEGER ARRAY JITINFO(0:26) = Q;    << Q+14 >>                       28552000
   ARRAY USERID(*) = JITINFO(15);  << user name >>                      28554000
   BYTE POINTER JITUSERID := @USERID;                                   28556000
<< DOUBLE UCAP = JITINFO+25;  << user capabilities >>                   28558000
                                                                        28560000
   << Remote file access (RFA) variables >>                             28562000
                                                                        28564000
<<   INTEGER POINTER RFAPTR;    << appendage pointer >>                 28566000
<<   INTEGER RFALEN;            << appendage length >>                  28568000
     INTEGER POINTER AFT;       << for KSAM >>                          28570000
                                                                        28572000
                                                                        28574000
   SUBROUTINE LABELIO (RW);                                             28576000
      << Reads or writes the file label into the stack buffer.          28578000
                                                                        28580000
        INPUT VARIABLES:                                                28582000
            RW - I/O MODE                                               28584000
               0 - READ                                                 28586000
               1 - WRITE                                                28588000
                                                                        28590000
     DB must be at the stack when this subroutine is called.   >>       28592000
                                                                        28594000
   VALUE RW;                                                            28596000
   INTEGER RW;                                                          28598000
      BEGIN                                                             28600000
      X := FLABIO(DADDR,LABADR,RW,FLAB);  <<R/W LABEL>>                 28602000
      IF <> THEN                                                        28604000
         BEGIN     << Error. >>                                         28606000
         FLABIOERR(X,FILENUM);  << handle error >>                      28608000
         TOS := LBLIOERR;                                               28610000
         TOS := CCL;                                                    28612000
         GO STACKERR                                                    28614000
         END                                                            28616000
      END;        << subroutine LABELIO >>                              28618000
SUBROUTINE EXCEPTION(CONDITION);                                        28620000
VALUE CONDITION;                                                        28622000
INTEGER CONDITION;                                                      28624000
   BEGIN                                                                28626000
   CC' := CCG;                                                          28628000
   IF SET'EXCOND THEN EXCOND := CONDITION;                              28630000
   END;     << subroutine EXCEPTIION >>                                 28632000
                                                                        28634000
$  IF X0 = ON                                                           28636000
   IF MONCALLABLE THEN                                                  28638000
      BEGIN       << monitoring >>                                      28640000
      FTITLE("FALT","SEC ",0D,0D);                                      28642000
      DEBUG                                                             28644000
      END;                                                              28646000
$  IF                                                                   28648000
                                                                        28650000
   ERRORON;                                                             28652000
   CRIT := SETCRITICAL;                                                 28654000
   IF NOFILENUM THEN                                                    28656000
      BEGIN                                                             28658000
      TOS := INVFN;                                                     28660000
      TOS := CCL;                                                       28662000
      GO EXIT;                                                          28664000
      END;                                                              28666000
   LOC'ACB(*,14,FILENUM,UMODE);                                         28668000
   DSTX := TOS;          << DB at entry condition.  >>         <<04568>>28670000
                         << This will not affect CC >>         <<04568>>28672000
   IF < THEN                                                            28674000
      BEGIN     << Invalid file nr. >>                                  28676000
      TOS := INVFN;                                                     28678000
      TOS := CCL;                                                       28680000
      GO EXIT;                                                          28682000
   HELP;    << dummy call >>                                            28684000
      END;                                                              28686000
   IF > THEN                                                            28688000
      BEGIN      << $NULL >>                                            28690000
      TOS := 0;  << no error >>                                         28692000
      TOS := CCE;                                                       28694000
      GO EXIT                                                           28696000
      END;                                                              28698000
   IF DSTX <> 0 THEN                                                    28700000
      BEGIN       << DB not at stack. Boo! >>                           28702000
      TOS := ILLDB;                                                     28704000
      TOS := CCL;                                                       28706000
      GO ACBERR                                                         28708000
      END;                                                              28710000
   CASE FTYPE OF                                                        28712000
   BEGIN                                                                28714000
                                                                        28716000
   BEGIN    << conventional file >>                                     28718000
CONVENTIONAL:                                                  <<HM.00>>28720000
   IF ACB'FCB=0 OR ACB'SPOOLED THEN                                     28722000
      BEGIN       << Not disk file. >>                                  28724000
      TOS := DEVVIOL;                                                   28726000
      TOS := CCL;                                                       28728000
      GO ACBERR                                                         28730000
      END;                                                              28732000
   IF NOT ACBEXCLUSIVE AND NOT ACBDEFAULT OR ACBREAD THEN               28734000
      BEGIN                                                             28736000
      TOS := MLTIACCERR;                                                28738000
      TOS := CCL;                                                       28740000
      GO ACBERR                                                         28742000
      END;                                                              28744000
   A := GETSIR(FISIR);  << Get File SIR while diddling labels >>        28746000
                                                                        28748000
   <<* * * Get label address from FCB * * *>>                           28750000
                                                                        28752000
   TOS := 0;           << for LDEV >>                                   28754000
   TOS := GETFCB'INFO (ACB'FCB, SIZEBFCB);                     <<01624>>28756000
   TOS := TOS&TASL(8)&DLSR(8);  <<separate LDEV>>                       28758000
   LABADR := TOS;      << file label sector nr. >>                      28760000
   DADDR := TOS;       << file label LDEV >>                            28762000
                                                                        28764000
   <<* * * Read file label * * *>>                                      28766000
                                                                        28768000
   LABELIO(0);      << read file label >>                               28770000
   IF FLFILECODE < 0 AND NOT PRIVMODE THEN                              28772000
      BEGIN     << Caller must be Priv if file is. >>                   28774000
      TOS := PRIVVIOL;                                                  28776000
      TOS := CCL;                                                       28778000
      GO STACKERR;                                                      28780000
      END;                                                              28782000
                                                                        28784000
   <<* * * Get information in JIT * * *>>                               28786000
                                                                        28788000
   SETPCBX;       << init. PCBX pointer >>                              28790000
   TOS := @JITINFO;  << stack addr. >>                                  28792000
   TOS := PXGJITDST; TOS := JITASEC;  <<JIT loc.>>                      28794000
   TOS := 27;                                                           28796000
   ASSEMBLE(MFDS 4);                                                    28798000
                                                                        28800000
   << Compare user name in JIT with file label creator ID >>            28802000
                                                                        28804000
   IF JITUSERID <> CREATOR,(8) THEN                                     28806000
      BEGIN    << creator violation >>                                  28808000
      TOS := USERIDVIOL;                                                28810000
      TOS := CCL;                                                       28812000
      GO STACKERR                                                       28814000
      END;                                                              28816000
                                                                        28818000
   << Check to see if "old" security info should be returned. >>        28820000
   IF RTN'OLDFLAG THEN OLDFLAG := FLSECURE;                             28822000
   IF RTN'OLDMATRIX THEN OLDMATRIXDBL := FLSECMX;                       28824000
                                                                        28826000
   CC' := CCE;                                                          28828000
   IF SET'EXCOND THEN EXCOND := 0;                                      28830000
                                                                        28832000
   IF CHANGE'SECURITY THEN                                              28834000
      BEGIN      << Some change will be made. >>                        28836000
      IF SET'SECUREFLAG THEN    << Want to release or secure file >>    28838000
         BEGIN                                                          28840000
         IF FILE'SECURED THEN                                           28842000
            IF NEWSECUREFLAG           << Want to secure it ! >>        28844000
               THEN EXCEPTION(1)                                        28846000
               ELSE FLSECURE := 0        <<      Release it  >>         28848000
                                                                        28850000
            ELSE IF NEWSECUREFLAG   << File is currently released>>     28852000
               THEN FLSECURE := 1     << Secure it           >>         28854000
               ELSE EXCEPTION(2);   <<   Want to release it>>           28856000
         END;                                                           28858000
                                                                        28860000
      IF SET'MATRIX THEN                                                28862000
         BEGIN     << Set new file label security matrix. >>            28864000
                                                                        28866000
         IF NOT(FILE'SECURED             << Why change it for a >>      28868000
            LOR SET'SECUREFLAG)          << released file or if >>      28870000
            OR NOT NEWSECUREFLAG         << just released it?   >>      28872000
         THEN EXCEPTION(3);                                             28874000
                                                                        28876000
         TOS := NEWMATRIXDBL;   << Put new matrix on top of stack >>    28878000
         IF = THEN                                                      28880000
            BEGIN      << New matrix all zeroes; make no change. >>     28882000
            DDEL;                                                       28884000
            EXCEPTION(4);                                               28886000
            END                                                         28888000
         ELSE                                                           28890000
            BEGIN       << Want to make some change to matrix >>        28892000
            DEL;         << Leaves word 0 of NEWMATRIX on TOS >>        28894000
                                                                        28896000
            CASE SELECT'MATRIX OF  << Based on TOS bits (0:2) >>        28898000
               BEGIN                                                    28900000
              << Bits: 00 --- Use supplied matrix >>                    28902000
                BEGIN                                                   28904000
                TOS := NEWMATRIX.(2:14);                                28906000
                TOS := NEWMATRIX(1);                                    28908000
                END;                                                    28910000
             << Bits: 01 --- Use creator-only matrix >>                 28912000
                BEGIN                                                   28914000
                TOS := CREATORMATRIX;                                   28916000
                END;                                                    28918000
             << Bits: 10 --- Use default matrix >>                      28920000
                BEGIN                                                   28922000
                TOS := DEFAULTMATRIX;                                   28924000
                END;                                                    28926000
             << Bits: 11 --- Selected both! Use creator-only >>         28928000
                BEGIN                                                   28930000
                TOS := CREATORMATRIX;                                   28932000
                EXCEPTION(5);                                           28934000
                END;                                                    28936000
                END;  << CASE on SELECT'MATRIX >>                       28938000
                                                                        28940000
             FLSECMX := TOS;        << Change it (2 wds on TOS) >>      28942000
             END;  << make change to matrix >>                          28944000
                                                                        28946000
         END;     << set new matrix >>                                  28948000
                                                                        28950000
     <<* * * Write updated file label * * *>>                           28952000
                                                                        28954000
      FLLASTMOD := CALENDAR;  << update modification date >>            28956000
      LABELIO(1);     << write file label >>                            28958000
      END;                                                              28960000
                                                                        28962000
   <<* * * Measurement data on FALTSEC * * *>>                          28964000
                                                                        28966000
$  IF X3 = ON                                                           28968000
   IF MEAS'TAPE'ON THEN BEGIN                                           28970000
   MMSTAT(EFALTSEC,FILENUM,0,0);  <<MEASURE EVENT>>                     28972000
   END; << of MEAS'TAPE'ON>>                                            28974000
$  IF                                                                   28976000
                                                                        28978000
   TOS := 0;    << no error >>                                          28980000
   TOS := CC';  << either CCE or CCG at this point >>                   28982000
                                                                        28984000
STACKERR:                                                               28986000
                                                                        28988000
ACBERR:                                                                 28990000
   ACB'ERROR := S1;  << error nr. >>                                    28992000
   IF A <> -1 THEN RELSIR(FISIR,A);                                     28994000
   UNLOC'ACB(14,0);       << release ACB >>                             28996000
   END;      << conventional file >>                                    28998000
                                                                        29000000
   BEGIN << remote file >>                                              29002000
   END;  << remote file >>                                              29004000
                                                                        29006000
      << dummy 2>>;                                                     29008000
      << dummy 3>>;                                                     29010000
      << dummy 4>>;                                                     29012000
      << dummy 5>>;                                                     29014000
   BEGIN    << KSAM file >>                                             29016000
   DSTX := EXCHANGEDB(0);                                               29018000
   SETAFT;                                                              29020000
   AFTFLAG := 3;      << KSAM error >>                                  29022000
   AFTERRNUM := UNIMPL;    <<"unimplemented">>                          29024000
   TOS := UNIMPL;       <<"unimplemented">>                             29026000
   TOS := CCL;                                                          29028000
   EXCHANGEDB(DSTX);                                                    29030000
   END;      <<KSAM file >>                                             29032000
   <<DUMMY 7>>;                                                <<HM.00>>29034000
   GO CONVENTIONAL;                                            <<HM.00>>29036000
   END;     << FTYPE CASE >>                                            29038000
EXIT:                                                                   29040000
   CONDCODE := TOS;  << report condition code >>                        29042000
   RESETCRITICAL(CRIT);                                                 29044000
   ERROREXIT(7,S0,0)                                                    29046000
   END;     << procedure FALTSEC >>                                     29048000
$PAGE "3000/30 FILE SYSTEM - FINTSTATE, FINTEXIT"              <<03038>>29050000
$CONTROL SEGMENT=FILESYS2                                      <<03038>>29052000
                                                               <<03038>>29054000
LOGICAL PROCEDURE FINTSTATE(NEWSTATE);                         <<03038>>29056000
VALUE NEWSTATE;                                                <<03038>>29058000
                                                               <<03038>>29060000
<<FUNCTION                                                       HM.XX  29062000
  ENABLES/DISABLES FILE SOFT INTERRUPTS AGAINST THE PROCESS.>> <<03038>>29064000
                                                               <<03038>>29066000
<<INPUT>>                                                      <<03038>>29068000
  LOGICAL                                                      <<03038>>29070000
    NEWSTATE;            <<(15:1):  0 - DISABLE FS INTERRUPTS    HM.XX  29072000
                                    1 - ENABLE FILE SYS INTS     HM.XX  29074000
                           (0:15):  IGNORED.>>                 <<03038>>29076000
<<OUTPUT                                                         HM.XX  29078000
    FINTSTATE              OLD VALUE OF THE FILE SYSTEM INT      HM.XX  29080000
                           STATE.>>                            <<03038>>29082000
                                                               <<03038>>29084000
OPTION PRIVILEGED;                                             <<03038>>29086000
                                                               <<03038>>29088000
   BEGIN                                                       <<03038>>29090000
   DEFINE                                                      <<03038>>29092000
      INTSTATEHANG= [10/24,6/1]#;                              <<03038>>29094000
                                                               <<03038>>29096000
   <<INITIALIZE>>                                              <<03038>>29098000
   ERRORON;                                                    <<03038>>29100000
   FINTSTATE:=CHANGEINTSTATE(NEWSTATE);                        <<03038>>29102000
   ERROREXIT(INTSTATEHANG,0,0);                                <<03038>>29104000
   END;  <<FINTSTATE>>                                         <<03038>>29106000
$CONTROL SEGMENT=FILESYS2                                      <<03038>>29108000
PROCEDURE FINTEXIT(NEWSTATE);                                  <<03038>>29110000
VALUE NEWSTATE;                                                <<03038>>29112000
                                                               <<03038>>29114000
<<FUNCTION                                                       HM.XX  29116000
  EXITS FROM A USER SOFT INTERRUPT PROCEDURE.>>                <<03038>>29118000
                                                               <<03038>>29120000
<<INPUT>>                                                      <<03038>>29122000
  LOGICAL                                                      <<03038>>29124000
    NEWSTATE;            <<(15:1):  0 - DISABLE FS INTERRUPTS    HM.XX  29126000
                                    1 - ENABLE FILE SYSTEM INTS  HM.XX  29128000
                           (0:15):  IGNORED.>>                 <<03038>>29130000
                                                               <<03038>>29132000
  <<OUTPUT                                                       HM.XX  29134000
    NONE.>>                                                    <<03038>>29136000
                                                               <<03038>>29138000
  <<NOTE: THE CALLING PROCEDURE'S STACK MARKER IS DELETED,       HM.XX  29140000
          CONTROL IS RETURNED TO THE INTERRUPTED PROCEDURE       HM.XX  29142000
          UNLESS:                                                HM.XX  29144000
                                                                 HM.XX  29146000
            1. THE NEWSTATE PARAMETER SPECIFIES THAT INTERRUPTS  HM.XX  29148000
               BE ENABLED,                                       HM.XX  29150000
            2. AND ONE OR MORE INTERRUPTS ARE PENDING.>>       <<03038>>29152000
                                                               <<03038>>29154000
OPTION PRIVILEGED,VARIABLE;                                    <<03038>>29156000
                                                               <<03038>>29158000
   BEGIN                                                       <<03038>>29160000
   EQUATE                                                      <<03038>>29162000
      INTEXITHANG   = [10/23,6/1];                             <<03038>>29164000
   LOGICAL                                                     <<03038>>29166000
      PMAP=Q-4,NEWSTATE'=Q+1;                                  <<03038>>29168000
   INTEGER                                                     <<03038>>29170000
      STATUS=Q-1,DELTAQ=Q-0;                                   <<03038>>29172000
   INTEGER ARRAY                                               <<03038>>29174000
      Q0ARRAY(*)=Q-0;                                          <<03038>>29176000
                                                               <<03038>>29178000
   <<INSURE THAT THE STACK MARKER IS HARMLESS>>                <<03038>>29180000
   ERRORON;                                                    <<03038>>29182000
   IF STATUS >= 0 AND Q0ARRAY(-DELTAQ-1) < 0  <<NONPRIV=>PRIV>><<03038>>29184000
   OR Q0ARRAY(-DELTAQ) < 0 THEN  <<DELTA Q GOING NEGATIVE>>    <<03038>>29186000
      ABORT(0,22,0);                                           <<03038>>29188000
                                                               <<03038>>29190000
   <<DELETE THE CALLER'S STACK MARKER>>                        <<03038>>29192000
   X:=IF PMAP THEN NEWSTATE ELSE 1;                            <<03038>>29194000
   PUSH(Q); TOS:=TOS-DELTAQ; SET(Q);                           <<03038>>29196000
   NEWSTATE':=X;                                               <<03038>>29198000
                                                               <<03038>>29200000
   <<UPDATE THE PROCESS'S INTERRUPT STATUS>>                   <<03038>>29202000
   CHANGEINTSTATE(NEWSTATE');                                  <<03038>>29204000
                                                               <<03038>>29206000
   ERROREXIT(INTEXITHANG,0,0);                                 <<03038>>29208000
   END;  <<FINTEXIT>>                                          <<03038>>29210000
$PAGE "3000/30 FILE SYSTEM - OUTER BLOCK"                      <<03038>>29212000
$CONTROL SEGMENT=FLESYS, MAP  << OUTER BLOCK >>                <<03038>>29214000
END.   << End of File System >>                                <<03038>>29216000
