$CONTROL USLINIT,CODE,MAP                                      <<01549>>00005000
<<ALLOCATE - MODULE 54>>                                       <<01549>>00010000
<< HP32002C MPE SOURCE C.00.00 >>                                       00015000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00020000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00025000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00030000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00035000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00040000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00045000
                                                               <<04620>>00050000
                                                               <<04620>>00055000
$THIRTY                                                                 00060000
$CONTROL PRIVILEGED                                            <<00652>>00065000
$CONTROL MAIN=ALOCATE                                          <<00652>>00070000
BEGIN                                                                   00075000
                                                               <<03698>>00080000
<<  Changes made to ALLOCATE module since 1/19/82          >>  <<03698>>00085000
                                                               <<03698>>00090000
<<  Fix the check made for tapes and serial discs for      >>  <<03698>>00095000
<<  unlabeled "tapes".                                     >>  <<03698>>00100000
                                                               <<03698>>00105000
<< Make sure a request for disc (fdisc/sdisc) fails if PV  >>  <<03788>>00110000
<<  is on the ldev.                                        >>  <<03788>>00115000
<< New option in DEALLOCATE for MORGUE.                    >>  <<04201>>00120000
<< Release LDTSIR before ATTACHIO calls in DEALLOCATE.       >><<04843>>00125000
<< Take out Halt 0                                         >>  <<04622>>00130000
                                                               <<06730>>00135000
<< Change to incorporate $INCLUDE files for LDT, LPDT.      >> <<06730>>00140000
<< Change to incorporate $INCLUDE file for XDD.             >> <<06730>>00145000
                                                               <<04622>>00150000
<< Call to CKFORLABEL (in LABSEG) split into two procedure >>  <<06027>>00155000
<< calls, CKFORLDEV and CKFOREXDATE.                       >>  <<06027>>00160000
                                                               <<06027>>00165000
<< Incorporate SYSGLOB $INCLUDE file.                       >> <<07050>>00170000
                                                               <<07050>>00175000
<< Return PRIMEDEVICE FOPEN FLAGS parm to %17 (from 7) to   >> <<S8098>>00180000
<<   avoid SF661.                                           >> <<S8098>>00185000
<< In DEALLOCATE, convert XDD VTAB to LDEV before deallo-   >> <<S8651>>00190000
<<   cating first spoolfile extent.                         >> <<S8651>>00195000
<< In ASKOP, delete type requirement for auto allocation.   >> <<A8986>>00200000
<<   (SYSDUMP/INITIAL manages LPDT'AUTO'ALLOC).  Makes it   >> <<A8986>>00205000
<<   possible to auto-allocate unlabelled SDISC.  Assume    >> <<A8986>>00210000
<<   write ring is O.K. for such requests.                  >> <<A8986>>00215000
$PAGE "***  GENERAL/GLOBAL EQUIVALENCES   ***"                          00220000
DEFINE                                                                  00225000
           PENABLE           = ASSEMBLE(PSEB)    #,            <<06730>>00230000
           PDISABLE          = ASSEMBLE(PSDB)    #,            <<06730>>00235000
           DISABLE           = ASSEMBLE(SED 0)   #,                     00240000
           ENABLE            = ASSEMBLE(SED 1)   #,            <<06730>>00245000
           STACK             = 0                 #;            <<06730>>00250000
DEFINE                                                         <<03546>>00255000
           LOCK             = 16                 #,            <<03546>>00260000
           UNLOCK           = 17                 #;            <<03546>>00265000
INTEGER                                                                 00270000
           S0                = S-0   ,                                  00275000
           X                 = X     ;                         <<07050>>00280000
                                                               <<06730>>00285000
BYTE POINTER                                                   <<06730>>00290000
           BPS0              = S-0   ;                         <<06730>>00295000
                                                               <<06730>>00300000
$PAGE "***   TABLE CONSTANTS   ***"                            <<06730>>00305000
EQUATE                                                                  00310000
           MVTABSIR          = 27    ,                         <<RH.PV>>00315000
           MVTABDST          = 53    ,                         <<RH.PV>>00320000
           MVTABSIZE         = 21    ;                         <<06730>>00325000
$SET X8 = ON                                                   <<06730>>00330000
$INCLUDE INCLSYSG                                              <<07050>>00335000
$INCLUDE INCLLDT5                                              <<06730>>00340000
$INCLUDE INCLLPDT                                              <<06730>>00345000
$INCLUDE INCLDCT                                               <<06730>>00350000
$PAGE "MPE TABLE ACCESS:  PXGLOBAL"                            <<06730>>00355000
$INCLUDE INCLPXG                                               <<06730>>00360000
$TITLE "MPE TABLE ACCESS:  USER CAPABILITIES"                  <<06730>>00365000
$INCLUDE INCLCAP                                               <<06730>>00370000
$PAGE "MPE TABLE ACCESS:  PCB"                                 <<06730>>00375000
$INCLUDE INCLPCB5                                              <<06730>>00380000
$INCLUDE INCLXDD5                                              <<06730>>00385000
$PAGE "***   FURTHER EQUIVALENCES   ***"                                00390000
   EQUATE                                                               00395000
         WORDS'PER'SECTOR = 128,                               <<06730>>00400000
                                                               <<06730>>00405000
         OLDDATA          =   0,  << For ASKOP and ALLOCATE >> <<06730>>00410000
         REALLOC          =   1,                               <<06730>>00415000
         OPASSIGNED       =   2;                               <<06730>>00420000
                                                               <<06730>>00425000
   DEFINE                                                      <<06730>>00430000
         CC           = STATUS.(6:2)#,                         <<06730>>00435000
         CCE          = 2 #,                                            00440000
         CCG          = 0 #,                                            00445000
         CCL          = 1 #;                                   <<06730>>00450000
   DEFINE                                                      <<RH.PV>>00455000
         PVCLASSF     = (0:1)#,                                <<RH.PV>>00460000
         MVTABXF      = (4:4)#,                                <<RH.PV>>00465000
         VMASKF       = (8:8)#,                                <<RH.PV>>00470000
         CYCPF        = (1:4)#;                                <<RH.PV>>00475000
   EQUATE                                                      <<SD.00>>00480000
      MEMSIZE = %77700,    << Max size for sdisc XDS >>        <<03563>>00485000
         VDSIZE  = 0;                                          <<SD.00>>00490000
                                                               <<07050>>00495000
   EQUATE            << Suddendeath EQUATEs for easy XREF.  >> <<07050>>00500000
      SD350 = 350,                                             <<07050>>00505000
      SD351 = 351,                                             <<07050>>00510000
      SD352 = 352,                                             <<07050>>00515000
      SD353 = 353,                                             <<07050>>00520000
      SD354 = 354,                                             <<07050>>00525000
      SD360 = 360,                                             <<07050>>00530000
      SD361 = 361,                                             <<07050>>00535000
      SD362 = 362,                                             <<07050>>00540000
      SD363 = 363,                                             <<07050>>00545000
      SD364 = 364,                                             <<07050>>00550000
      SD365 = 365,                                             <<07050>>00555000
      SD366 = 366,                                             <<07050>>00560000
      SD367 = 367;                                             <<07050>>00565000
$PAGE "ASSOCIATION TABLE DEFINITIONS AND DECLARATIONS"         <<01647>>00570000
                                                               <<01647>>00575000
EQUATE                                                         <<01647>>00580000
   ASS'DST       = 34,          << ASSOC. TABLE DST.     >>    <<01647>>00585000
   ASS'ENTRYSIZE = 7,           << IN WORDS.             >>    <<01647>>00590000
   ASS'CLASS     = 3,           << CLASSNAME INDEX       >>    <<01647>>00595000
   ASS'SIR       = 24;          << ASSOC. TABLE SIR.     >>    <<01647>>00600000
                                                               <<01647>>00605000
DEFINE                                                         <<01647>>00610000
   ASS'JMAT      = 0).(8:8 #,   << JMAT INDEX IN ENTRY.  >>    <<01647>>00615000
   ASS'JIT       = 1).(6:10 #;  << JIT INDEX IN ENTRY.   >>    <<01647>>00620000
                                                               <<01647>>00625000
DEFINE                                                         <<01647>>00630000
   LOCK'ASS'TABLE  = ASSOC'SIR := GETSIR( ASS'SIR ) #,         <<01647>>00635000
   FREE'ASS'TABLE  = RELSIR( ASS'SIR, ASSOC'SIR )   #;         <<01647>>00640000
                                                               <<01647>>00645000
<< Subroutine "declarations" for MOVEFROMDSEG,  MOVETODSEG. >> <<06730>>00650000
<< To use, declare "SUBROUTINE DEF'MOVExxDSEG" in each pro- >> <<06730>>00655000
<< cedure requiring it. Note that DBSOURCE and DBTARGET are >> <<06730>>00660000
<< LOGICAL, not LOGICAL POINTER.  This makes it  easier  to >> <<06730>>00665000
<< move one or two word quantities from/to single or double >> <<06730>>00670000
<< word cells which are not arrays or pointers. Remember to >> <<06730>>00675000
<< include the "@" sign, no matter what its attribute is.   >> <<06730>>00680000
                                                               <<06730>>00685000
DEFINE                                                         <<06730>>00690000
                                                               <<06730>>00695000
   DEF'MOVEFROMDSEG =                                          <<06730>>00700000
      MOVEFROMDSEG (DBTARGET, DSTN, DSTOFFSET, WORD'COUNT);    <<06730>>00705000
         VALUE   DBTARGET, DSTN, DSTOFFSET, WORD'COUNT;        <<06730>>00710000
         LOGICAL DBTARGET, DSTN, DSTOFFSET, WORD'COUNT;        <<06730>>00715000
      BEGIN                                                    <<06730>>00720000
      X := TOS;            << Save    return address.       >> <<06730>>00725000
      ASSEMBLE (MFDS 0);                                       <<06730>>00730000
      TOS := X;            << Restore return address.       >> <<06730>>00735000
      END #,                                                   <<06730>>00740000
                                                               <<06730>>00745000
   DEF'MOVETODSEG =                                            <<06730>>00750000
      MOVETODSEG (DSTN, DSTOFFSET, DBSOURCE, WORD'COUNT);      <<06730>>00755000
         VALUE   DSTN, DSTOFFSET, DBSOURCE, WORD'COUNT;        <<06730>>00760000
         LOGICAL DSTN, DSTOFFSET, DBSOURCE, WORD'COUNT;        <<06730>>00765000
      BEGIN                                                    <<06730>>00770000
      X := TOS;                                                <<06730>>00775000
      ASSEMBLE (MTDS 0);                                       <<06730>>00780000
      TOS := X;                                                <<06730>>00785000
      END #;                                                   <<06730>>00790000
$PAGE "***   EXTERNAL PROCEDURES   ***"                                 00795000
                                                                        00800000
PROCEDURE ABORTIO (LDEV);                                               00805000
   VALUE   LDEV;                                                        00810000
   INTEGER LDEV;                                                        00815000
   OPTION EXTERNAL;                                                     00820000
                                                                        00825000
LOGICAL PROCEDURE ALTDSEGSIZE(DSTX,SIZE);                               00830000
   VALUE DSTX,SIZE;                                                     00835000
   INTEGER DSTX,SIZE;                                                   00840000
   OPTION EXTERNAL;                                                     00845000
                                                                        00850000
DOUBLE PROCEDURE ATTACHIO (LDEV,QM,D,B,F,C,P1,P2,FL);                   00855000
   VALUE   LDEV,QM,D,B,F,C,P1,P2,FL;                                    00860000
   INTEGER LDEV,QM,D,B,F,C,P1,P2,FL;                                    00865000
   OPTION EXTERNAL;                                                     00870000
                                                               <<06730>>00875000
DOUBLE PROCEDURE P'ATTACHIO (LDNUM, QMISC, DSTX, OFFSET,       <<06730>>00880000
                 FUNCTION, COUNT, P1, P2, FLAGS,               <<06730>>00885000
                 EXTENT'BASE, EXTENT'LENGTH);                  <<06730>>00890000
   VALUE   LDNUM, QMISC, DSTX, OFFSET, FUNCTION, COUNT, P1,    <<06730>>00895000
           P2, FLAGS, EXTENT'BASE, EXTENT'LENGTH;              <<06730>>00900000
   INTEGER LDNUM, QMISC, DSTX, OFFSET, FUNCTION, COUNT, P1,    <<06730>>00905000
           P2, FLAGS, EXTENT'LENGTH;                           <<06730>>00910000
   DOUBLE EXTENT'BASE;                                         <<06730>>00915000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL, VARIABLE;          <<06730>>00920000
                                                                        00925000
DOUBLE PROCEDURE REQSTATUS(LDEV);                              <<03698>>00930000
  VALUE LDEV;                                                  <<03698>>00935000
  INTEGER LDEV;                                                <<03698>>00940000
  OPTION EXTERNAL;                                             <<03698>>00945000
                                                               <<03698>>00950000
PROCEDURE AWAKE(PCBPT,N,WAITF);                                         00955000
   VALUE PCBPT,N,WAITF;                                                 00960000
   INTEGER PCBPT,N,WAITF;                                               00965000
   OPTION EXTERNAL;                                                     00970000
                                                                        00975000
LOGICAL PROCEDURE CALENDAR;                                             00980000
   OPTION EXTERNAL;                                                     00985000
                                                                        00990000
                                                                        00995000
PROCEDURE CLEAN'MESSAGE(MSG,LEN);                                       01000000
   VALUE LEN;                                                           01005000
   INTEGER LEN;                                                         01010000
   BYTE ARRAY MSG;                                                      01015000
   OPTION PRIVILEGED,UNCALLABLE,EXTERNAL;                               01020000
                                                                        01025000
DOUBLE PROCEDURE CLOCK;                                                 01030000
   OPTION EXTERNAL;                                                     01035000
                                                                        01040000
LOGICAL PROCEDURE EXCHANGEDB(DSTX);                                     01045000
   VALUE DSTX;                                                          01050000
   LOGICAL DSTX;                                                        01055000
   OPTION EXTERNAL;                                                     01060000
                                                               <<0U.EB>>01065000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,MASK,B,C,D,E,F,           <<0U.EB>>01070000
      DEST,REPLY,BUFF,DST,IOTYPE);                             <<0U.EB>>01075000
   VALUE SETNO,MSGNO,MASK,B,C,D,E,F,DEST,REPLY,BUFF,           <<0U.EB>>01080000
      DST,IOTYPE;                                              <<0U.EB>>01085000
   LOGICAL SETNO,MSGNO,MASK,B,C,D,E,F,DEST,REPLY,BUFF,         <<0U.EB>>01090000
      DST,IOTYPE;                                              <<0U.EB>>01095000
   OPTION VARIABLE,EXTERNAL;                                   <<0U.EB>>01100000
                                                               <<01549>>01105000
Integer Procedure Get'DSDEVICE(Ldev);                          <<01549>>01110000
   Value Ldev;                                                 <<01549>>01115000
   Integer Ldev;                                               <<01549>>01120000
   OPTION PRIVILEGED,UNCALLABLE,EXTERNAL;                      <<01549>>01125000
                                                               <<01549>>01130000
LOGICAL PROCEDURE GETSIR(SIRNUM);                                       01135000
   VALUE SIRNUM;                                                        01140000
   INTEGER SIRNUM;                                                      01145000
   OPTION EXTERNAL;                                                     01150000
                                                                        01155000
LOGICAL PROCEDURE HEADER (ODDSUBP, LDEV, DEVTYPE, DEVRSIZE);            01160000
   VALUE ODDSUBP, LDEV, DEVTYPE, DEVRSIZE;                              01165000
   INTEGER POINTER ODDSUBP;                                             01170000
   INTEGER LDEV, DEVTYPE, DEVRSIZE;                                     01175000
   OPTION EXTERNAL;                                                     01180000
                                                               <<06730>>01185000
INTEGER PROCEDURE LDEVTOTYPE(LDEV);                            <<01357>>01190000
VALUE LDEV;                                                    <<01357>>01195000
INTEGER LDEV;                                                  <<01357>>01200000
OPTION EXTERNAL;                                               <<01357>>01205000
                                                               <<01357>>01210000
INTEGER PROCEDURE LINKLABEL(LDEVN,ACC);                        <<TL.02>>01215000
  VALUE ACC;                                                   <<TL.02>>01220000
  INTEGER LDEVN,ACC;                                           <<TL.02>>01225000
  OPTION EXTERNAL;                                             <<TL.02>>01230000
                                                               <<TL.02>>01235000
LOGICAL PROCEDURE CKFOREXDATE(LDEV,RDWR,LBLED);                <<06027>>01240000
 VALUE LDEV,RDWR,LBLED;                                        <<06027>>01245000
 INTEGER LDEV,RDWR,LBLED;                                      <<06027>>01250000
 OPTION EXTERNAL;                                              <<06027>>01255000
                                                               <<06027>>01260000
LOGICAL PROCEDURE CKFORLDEV(LDEV);                             <<06027>>01265000
   VALUE LDEV;                                                 <<06027>>01270000
   INTEGER LDEV;                                               <<06027>>01275000
   OPTION EXTERNAL;                                            <<06027>>01280000
                                                               <<06027>>01285000
PROCEDURE SET'LPDT'BOT(LDEV,VAL);                              <<02566>>01290000
   VALUE LDEV,VAL;                                             <<02566>>01295000
   INTEGER LDEV,VAL;                                           <<02566>>01300000
   OPTION EXTERNAL;                                            <<02566>>01305000
                                                               <<02566>>01310000
PROCEDURE STORE'DENSITY(LDEV,BUFFER,MODE);                     <<02566>>01315000
   VALUE LDEV,MODE;                                            <<02566>>01320000
   INTEGER LDEV,MODE;                                          <<02566>>01325000
   ARRAY BUFFER;                                               <<02566>>01330000
   OPTION EXTERNAL;                                            <<02566>>01335000
                                                                        01340000
PROCEDURE RELSIR(SIRNUM,ALREADY);                                       01345000
   VALUE SIRNUM,ALREADY;                                                01350000
   INTEGER SIRNUM;                                                      01355000
   LOGICAL ALREADY;                                                     01360000
   OPTION EXTERNAL;                                                     01365000
                                                                        01370000
LOGICAL PROCEDURE SYSPROC (LPIN);                                       01375000
   VALUE   LPIN;                                                        01380000
   LOGICAL LPIN;                                                        01385000
   OPTION EXTERNAL;                                                     01390000
                                                                        01395000
PROCEDURE SUDDENDEATH(ERRNUM);                                          01400000
   VALUE ERRNUM;                                                        01405000
   INTEGER ERRNUM;                                                      01410000
   OPTION EXTERNAL;                                                     01415000
                                                                        01420000
LOGICAL PROCEDURE TRAILER (ODDSUBP, LDEV, DEVTYPE, DEVRSIZE);           01425000
   VALUE ODDSUBP, LDEV, DEVTYPE, DEVRSIZE;                              01430000
   INTEGER POINTER ODDSUBP;                                             01435000
   INTEGER LDEV, DEVTYPE, DEVRSIZE;                                     01440000
   OPTION EXTERNAL;                                                     01445000
                                                                        01450000
INTEGER PROCEDURE ASSOC'CLASS(CLASSNAME);                      <<00552>>01455000
INTEGER ARRAY CLASSNAME;                                       <<00552>>01460000
OPTION EXTERNAL,PRIVILEGED;                                    <<00552>>01465000
                                                               <<00552>>01470000
PROCEDURE WRITEDSEG'SERIAL(D); << Special entry point for  >>  <<w7889>>01475000
   VALUE D;                    << WRITEDSEG, goes thru the >>  <<w7889>>01480000
   INTEGER D;                  << serial write queue       >>  <<w7889>>01485000
   OPTION EXTERNAL;                                            <<w7889>>01490000
                                                               <<00453>>01495000
INTEGER PROCEDURE GETDATASEG(MEMSIZE,VDSIZE);                  <<SD.00>>01500000
VALUE MEMSIZE,VDSIZE;                                          <<SD.00>>01505000
INTEGER MEMSIZE,VDSIZE;                                        <<SD.00>>01510000
OPTION EXTERNAL;                                               <<SD.00>>01515000
                                                               <<SD.00>>01520000
PROCEDURE RELDATASEG(DSTN);                                    <<SD.00>>01525000
VALUE DSTN;                                                    <<SD.00>>01530000
INTEGER DSTN;                                                  <<SD.00>>01535000
OPTION EXTERNAL;                                               <<SD.00>>01540000
                                                               <<SD.00>>01545000
LOGICAL PROCEDURE PUTDEV(LDEV,TABLE,BUF);                      <<SP.01>>01550000
   VALUE LDEV,TABLE;                                           <<SP.01>>01555000
   INTEGER LDEV,TABLE;                                         <<SP.01>>01560000
   INTEGER ARRAY BUF;                                          <<SP.01>>01565000
   OPTION FORWARD;                                             <<SP.01>>01570000
                                                               <<SP.01>>01575000
LOGICAL PROCEDURE GETDEV(LDEV,TABLE,BUF);                      <<SP.01>>01580000
   VALUE LDEV,TABLE;                                           <<SP.01>>01585000
   INTEGER LDEV,TABLE;                                         <<SP.01>>01590000
   INTEGER ARRAY BUF;                                          <<SP.01>>01595000
   OPTION FORWARD;                                             <<SP.01>>01600000
                                                               <<SP.01>>01605000
INTEGER PROCEDURE Get'Disc'Space (ldev, number'of'sectors,     <<03507>>01610000
                                  disc'address);               <<03507>>01615000
   VALUE ldev, number'of'sectors;                              <<03507>>01620000
   INTEGER ldev;                                               <<03507>>01625000
   DOUBLE number'of'sectors, disc'address;                     <<03507>>01630000
   OPTION EXTERNAL;                                            <<03507>>01635000
                                                               <<03507>>01640000
PROCEDURE Return'Disc'Space (ldev, disc'address,               <<03507>>01645000
                             number'of'sectors);               <<03507>>01650000
   VALUE ldev, disc'address, number'of'sectors;                <<03507>>01655000
   INTEGER ldev;                                               <<03507>>01660000
   DOUBLE disc'address, number'of'sectors;                     <<03507>>01665000
   OPTION EXTERNAL;                                            <<03507>>01670000
                                                               <<03507>>01675000
LOGICAL PROCEDURE Deallocate'Dfs'Data'Seg (ldev);              <<03507>>01680000
   VALUE ldev;                                                 <<03507>>01685000
   INTEGER ldev;                                               <<03507>>01690000
   OPTION EXTERNAL;                                            <<03507>>01695000
                                                               <<03507>>01700000
PROCEDURE Delete'Dfs'Data'Seg (ldev);                          <<03507>>01705000
   VALUE ldev;                                                 <<03507>>01710000
   INTEGER ldev;                                               <<03507>>01715000
   OPTION EXTERNAL;                                            <<03507>>01720000
                                                               <<03507>>01725000
PROCEDURE PROCESS'DFS'ERROR (LDEV,ERROR'STATUS,TYPE'OF'ERROR); <<04811>>01730000
   VALUE LDEV,ERROR'STATUS,TYPE'OF'ERROR;                      <<04811>>01735000
   INTEGER LDEV;                                               <<04811>>01740000
   LOGICAL ERROR'STATUS;                                       <<04811>>01745000
   INTEGER TYPE'OF'ERROR;                                      <<04811>>01750000
   OPTION EXTERNAL;                                            <<04811>>01755000
                                                               <<04811>>01760000
PROCEDURE SOFT'DEATH (NUM);                                    <<04811>>01765000
   VALUE NUM;                                                  <<04811>>01770000
   INTEGER NUM;                                                <<04811>>01775000
   OPTION EXTERNAL;                                            <<04811>>01780000
                                                               <<04811>>01785000
INTEGER PROCEDURE LUN (VTAB'INDEX, MVTAB'INDEX);               <<07050>>01790000
   VALUE   VTAB'INDEX, MVTAB'INDEX;                            <<07050>>01795000
   INTEGER VTAB'INDEX, MVTAB'INDEX;                            <<07050>>01800000
   OPTION  PRIVILEGED, UNCALLABLE, EXTERNAL;                   <<07050>>01805000
  COMMENT -- Accepts a (system) volume table index and returns <<07050>>01810000
the corresponding LDEV in the result.  If MVTAB'INDEX <> 0 the <<07050>>01815000
(private) mounted volume table is searched instead.            <<07050>>01820000
;                                                              <<07050>>01825000
                                                               <<07050>>01830000
INTEGER PROCEDURE VTABINX (LDEV, LOCAL);                       <<07050>>01835000
   VALUE   LDEV, LOCAL;                                        <<07050>>01840000
   INTEGER LDEV;                                               <<07050>>01845000
   LOGICAL LOCAL;                                              <<07050>>01850000
   OPTION  PRIVILEGED, UNCALLABLE, EXTERNAL;                   <<07050>>01855000
  COMMENT -- Accepts a logical device number.  Returns the XDD <<07050>>01860000
head index in (0:8) of the result and the system volume  table <<07050>>01865000
index  in (8:8).  If LOCAL is FALSE, the volume table index is <<07050>>01870000
fetched from the LDT.  If TRUE, it is fetched from the  system <<07050>>01875000
volume table.                                                  <<07050>>01880000
;                                                              <<07050>>01885000
                                                               <<00652>>01890000
PROCEDURE HELP;                                                <<00868>>01895000
  OPTION EXTERNAL;                                             <<00868>>01900000
                                                               <<00868>>01905000
INTRINSIC ASCII;                                               <<06730>>01910000
$PAGE "***   Forward procedures   ***"                         <<06730>>01915000
LOGICAL PROCEDURE GETCLASS (RETURN'BUF, EVERYTHING, CLADR,     <<06730>>01920000
                            CLINDEX, CLNAME);                  <<06730>>01925000
   VALUE   CLADR, CLINDEX, EVERYTHING;                         <<06730>>01930000
   INTEGER CLADR, CLINDEX;                                     <<06730>>01935000
   LOGICAL EVERYTHING;                                         <<06730>>01940000
   INTEGER ARRAY CLNAME, RETURN'BUF;                           <<06730>>01945000
   OPTION  PRIVILEGED, UNCALLABLE, VARIABLE, FORWARD;          <<06730>>01950000
$PAGE "   ***   GET'DEVICE'CLASS   ***"                        <<06730>>01955000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>01960000
                                                               <<06730>>01965000
INTEGER PROCEDURE GET'DEVICE'CLASS (CLASS'INDEX,               <<06730>>01970000
                      ENTRY'ADDRESS);                          <<06730>>01975000
   VALUE   CLASS'INDEX;                                        <<06730>>01980000
   INTEGER CLASS'INDEX, ENTRY'ADDRESS;                         <<06730>>01985000
   OPTION PRIVILEGED, UNCALLABLE;                              <<06730>>01990000
BEGIN COMMENT --                                               <<06730>>01995000
  GET'DEVICE'CLASS accepts a Device Class Table index and  re- <<06730>>02000000
turns the length of its entry in the DCT and its segment-rela- <<06730>>02005000
tive offset in the DCT.  Callers can use this  information  to <<06730>>02010000
create a local copy of the entry.  New code should prefer this <<06730>>02015000
procedure over GETCLASS because it relies only on the $INCLUDE <<06730>>02020000
files for its information.  We still use  GETCLASS  here,  but <<06730>>02025000
only to obtain ENTRY'ADDRESS (the first word it returns).      <<06730>>02030000
                                                               <<06730>>02035000
    *-*-*  THIS IS NOT A REPLACEMENT FOR GETCLASS.   *-*-*     <<06730>>02040000
                                                               <<06730>>02045000
Inputs:   CLASS'INDEX.  The Nth entry (1 is first) in the  De- <<06730>>02050000
          vice Class Table.  Must be > 0.                      <<06730>>02055000
                                                               <<06730>>02060000
Returns:  Result.  The length of the entry, or -1 if the entry <<06730>>02065000
          doesn't exist.                                       <<06730>>02070000
                                                               <<06730>>02075000
          ENTRY'ADDRESS.  The DCT segment-relative address  of <<06730>>02080000
          the entry, or 0 if the entry doesn't exist.          <<06730>>02085000
                                                               <<06730>>02090000
Special considerations:  DB must be at  the  stack  on  entry, <<06730>>02095000
                         same at exit.  This is because of the <<06730>>02100000
                         stack DB-relative reference parameter <<06730>>02105000
                         ENTRY'ADDRESS.                        <<06730>>02110000
;                                                              <<06730>>02115000
LOGICAL ARRAY                                                  <<06730>>02120000
   DCT(0:SIZE'OF'DCT'HEAD-1);   << Req'd by DCT $INCL file. >> <<06730>>02125000
                                                               <<06730>>02130000
                                                               <<06730>>02135000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>02140000
                                                               <<06730>>02145000
                                                               <<06730>>02150000
IF GETCLASS (DCT <<temp>>, FALSE, <<cladr>>, CLASS'INDEX) THEN <<06730>>02155000
   BEGIN   << Entry exists.                                 >> <<06730>>02160000
   ENTRY'ADDRESS := DCT;   << First word retnd by GETCLASS. >> <<06730>>02165000
   MOVEFROMDSEG (@DCT, DCT'DST, ENTRY'ADDRESS,                 <<06730>>02170000
                 SIZE'OF'DCT'HEAD);                            <<06730>>02175000
   GET'DEVICE'CLASS := DCT'WORDS'IN'ENTRY;                     <<06730>>02180000
   END                                                         <<06730>>02185000
ELSE                                                           <<06730>>02190000
   BEGIN   << Entry doesn't exist.                          >> <<06730>>02195000
   GET'DEVICE'CLASS := -1;                                     <<06730>>02200000
   ENTRY'ADDRESS := 0;                                         <<06730>>02205000
   END;                                                        <<06730>>02210000
END;   << of GET'DEVICE'CLASS.                              >> <<06730>>02215000
$PAGE "   ***   SROOSTER   ***"                                <<06730>>02220000
$CONTROL SEGMENT= ALLOCUTIL                                             02225000
                                                                        02230000
                                                                        02235000
PROCEDURE SROOSTER (DEV'OR'CLASS);                             <<06730>>02240000
   VALUE   DEV'OR'CLASS;                                       <<06730>>02245000
   INTEGER DEV'OR'CLASS;                                       <<06730>>02250000
   OPTION  PRIVILEGED, UNCALLABLE;                             <<06730>>02255000
BEGIN COMMENT --                                               <<06730>>02260000
  SROOSTER wakes up output spooler processes by  satisfying  a <<06730>>02265000
son wait.  Processes which are already awake are unaffected by <<06730>>02270000
being AWAKEned again.  SROOSTER is called whenever a spoolfile <<06730>>02275000
is FCLOSEd (made READY), whenever the system outfence or a de- <<06730>>02280000
vice outfence changes or whenever  :ALTSPOOLFILE  changes  the <<06730>>02285000
device, class or priority of an output spoolfile.              <<06730>>02290000
                                                               <<06730>>02295000
Input:   DEV'OR'CLASS.  If > 0, an LDEV number.  Wake  up  its <<06730>>02300000
                        spooler if it exists.                  <<06730>>02305000
                        If < 0, a Device  Class  Table  index. <<06730>>02310000
                        Wake  up  all  spoolers for devices in <<06730>>02315000
                        the class.                             <<06730>>02320000
                        If 0, wake up all output spoolers.     <<06730>>02325000
                                                               <<06730>>02330000
Return:  None.  Condition code is not affected.                <<06730>>02335000
                                                               <<06730>>02340000
Special considerations:  DB may be anywhere at entry, same  at <<06730>>02345000
                         return. SROOSTER is most efficient if <<06730>>02350000
                         called with DB at the stack.          <<06730>>02355000
                                                               <<06730>>02360000
Ways and means:  Starting with MPE V, the Logical Device Table <<06730>>02365000
                 (LDT) and Device Class  Table  (DCT)  are  in <<06730>>02370000
                 different  data segments.  To avoid excessive <<06730>>02375000
                 EXCHANGEDB's, SROOSTER and  other  procedures <<06730>>02380000
                 which access both tables make local copies of <<06730>>02385000
                 the entries they work with. Since DCT entries <<06730>>02390000
                 are of variable length, any local  copy  must <<06730>>02395000
                 be built on the stack. References to this ar- <<06730>>02400000
                 ray must be indirect, therefore DB  must  re- <<06730>>02405000
                 main at the stack.                            <<06730>>02410000
;                                                              <<06730>>02415000
<< Note:  The following EQUATE is a parameter to the  AWAKE >> <<07050>>02420000
<< procedure,  and  represents  a  PCB  event mask position >> <<07050>>02425000
<< shifted right four bits.  It is currently unavailable in >> <<07050>>02430000
<< any $INCLUDE file, which is why it is here!  If the  un- >> <<07050>>02435000
<< derlying  event  mask  (or the AWAKE interface) changes, >> <<07050>>02440000
<< this EQUATE will also have to change.                    >> <<07050>>02445000
                                                               <<07050>>02450000
EQUATE                                                         <<07050>>02455000
   SONWAIT       = 2;                                          <<07050>>02460000
                                                               <<07050>>02465000
INTEGER                                                        <<06730>>02470000
   DST'AT'ENTRY := -1,                                         <<06730>>02475000
   ENTRY'ADDRESS,        << DCT-rel. offset to DCT entry.   >> <<06730>>02480000
   ENTRY'LENGTH,         << Length of entry at ENTRY'ADDRESS>> <<06730>>02485000
   PCBPT,                << Required by PCB $INCLUDE file.  >> <<06730>>02490000
   SAVE'DCT'SIR,                                               <<06730>>02495000
   SAVE'LDT'SIR;                                               <<06730>>02500000
                                                               <<06730>>02505000
LOGICAL                                                        <<06730>>02510000
   LOOP'COUNTER,                                               <<06730>>02515000
   NUM'LDT'ENTRIES;      << Local copy of LDT'NUM'ENTRIES.  >> <<06730>>02520000
                                                               <<06730>>02525000
LOGICAL ARRAY                                                  <<06730>>02530000
   LDT(0:SIZE'OF'LDT'ENTRY-1) = Q;                             <<07050>>02535000
                                                               <<06730>>02540000
LOGICAL POINTER                                                <<06730>>02545000
   DCT,                                                        <<06730>>02550000
   PCB = SYSPCBINDEX;                                          <<06730>>02555000
                                                               <<06730>>02560000
DEFINE                                                         <<06730>>02565000
   LDT'INDEX  = 0                      #,                      <<06730>>02570000
   LPDT'INDEX = LDEV * LPDT'ENTRY'SIZE #;                      <<06730>>02575000
                                                               <<06730>>02580000
                                                               <<06730>>02585000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>02590000
                                                               <<06730>>02595000
SUBROUTINE SROOST (LDEV);                                      <<06730>>02600000
   VALUE   LDEV;                                               <<06730>>02605000
   LOGICAL LDEV;                                               <<06730>>02610000
BEGIN                                                          <<06730>>02615000
IF NOT LPDT'VIRTUAL'DEVICE THEN                                <<06730>>02620000
   BEGIN   << Real device, wake it if it's spooled.         >> <<06730>>02625000
   MOVEFROMDSEG (@LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,      <<06730>>02630000
                 SIZE'OF'LDT'ENTRY);                           <<06730>>02635000
   IF LDT'SPOOL'STATE = LDT'OUTPUT'SPOOLED AND                 <<06730>>02640000
      LDT'MAIN'PIN <> 0 THEN                                   <<06730>>02645000
      AWAKE (LDT'MAIN'PIN * PCBSIZE, SONWAIT, 0);              <<06730>>02650000
   END;    << Real device.                                  >> <<06730>>02655000
END;       << of SROOST.                                    >> <<06730>>02660000
                                                               <<06730>>02665000
                                                               <<06730>>02670000
<< *-*-*   Procedure body starts here.                *-*-* >> <<06730>>02675000
                                                               <<06730>>02680000
PCBPT := CURPRC;                                               <<06730>>02685000
IF SPCBXDSDST <> STACK THEN DST'AT'ENTRY := EXCHANGEDB (STACK);<<06730>>02690000
SAVE'LDT'SIR := GETSIR (LDT'SIR);                              <<06730>>02695000
IF DEV'OR'CLASS > 0 THEN                                       <<06730>>02700000
   SROOST (DEV'OR'CLASS)   << Wake up one spooler.          >> <<06730>>02705000
ELSE IF DEV'OR'CLASS < 0 THEN                                  <<06730>>02710000
   BEGIN   << Device class request, get local copy of entry >> <<06730>>02715000
   SAVE'DCT'SIR := GETSIR (DCT'SIR);                           <<06730>>02720000
   ENTRY'LENGTH := GET'DEVICE'CLASS (-DEV'OR'CLASS,            <<06730>>02725000
                   ENTRY'ADDRESS);                             <<06730>>02730000
   IF ENTRY'LENGTH <> -1 THEN                                  <<06730>>02735000
      BEGIN   << Valid class index.                         >> <<06730>>02740000
      PUSH (S);                                                <<06730>>02745000
      @DCT := TOS + 1;   << Build DCT entry on stack.       >> <<06730>>02750000
      TOS := ENTRY'LENGTH;                                     <<06730>>02755000
      ASSEMBLE (ADDS 0);                                       <<06730>>02760000
      MOVEFROMDSEG (@DCT, DCT'DST, ENTRY'ADDRESS,              <<06730>>02765000
                    ENTRY'LENGTH);                             <<06730>>02770000
      LOOP'COUNTER := 0;   << Wake all spoolers in class.   >> <<06730>>02775000
      DO SROOST (DCT(DCT'FIRST'LDEV + LOOP'COUNTER)) UNTIL     <<06730>>02780000
         (LOOP'COUNTER := LOOP'COUNTER + 1) >= DCT'NUM'DEVICES;<<06730>>02785000
      END;    << Valid class index.                         >> <<06730>>02790000
   RELSIR (DCT'SIR, SAVE'DCT'SIR);                             <<06730>>02795000
   END        << Device class request...                    >> <<06730>>02800000
ELSE                                                           <<06730>>02805000
   BEGIN   << DEV'OR'CLASS = 0, wake all output spoolers.   >> <<06730>>02810000
                                                               <<06730>>02815000
<< ***CAUTION*** SROOST is called  for  all  LDEVs  (except >> <<06730>>02820000
<< LDEV  1)  on  the  system.  Proper  operation depends on >> <<06730>>02825000
<< SROOST continuing to wake ONLY real devices  which  have >> <<06730>>02830000
<< been  spooled out.  Even so, it can take a while on sys- >> <<06730>>02835000
<< tems with a large number of real devices.                >> <<06730>>02840000
                                                               <<06730>>02845000
   LOOP'COUNTER := 2;                                          <<06730>>02850000
   MOVEFROMDSEG (@LDT, LDT'DST, 0 << base of segment >>,       <<06730>>02855000
                 SIZE'OF'LDT'ENTRY);   << Master entry.     >> <<06730>>02860000
   NUM'LDT'ENTRIES := LDT'NUM'ENTRIES;                         <<06730>>02865000
   DO SROOST (LOOP'COUNTER) UNTIL                              <<06730>>02870000
      (LOOP'COUNTER := LOOP'COUNTER + 1) > NUM'LDT'ENTRIES;    <<06730>>02875000
   END;    << Wake all output spoolers.                     >> <<06730>>02880000
RELSIR (LDT'SIR, SAVE'LDT'SIR);                                <<06730>>02885000
                                                               <<06730>>02890000
<< The following call to HELP forces an STT  entry.  It  is >> <<06730>>02895000
<< never executed.                                          >> <<06730>>02900000
                                                               <<06730>>02905000
IF FALSE THEN HELP;                                            <<06730>>02910000
END;   << of SROOSTER.                                      >> <<06730>>02915000
$PAGE "   ***   ALLOCENTRY   ***"                              <<06730>>02920000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>02925000
                                                                        02930000
LOGICAL PROCEDURE ALLOCENTRY;                                           02935000
   OPTION PRIVILEGED, UNCALLABLE;                                       02940000
                                                               <<06730>>02945000
BEGIN                                                          <<06730>>02950000
  COMMENT -- ALLOCENTRY searches the IDD or ODD (DB must be at <<06730>>02955000
the proper XDS on entry, same at exit) for an available suben- <<06730>>02960000
try.  The first word of an available subentry is 0. If no sub- <<06730>>02965000
entry is available in the currently allocated XDS, the segment <<06730>>02970000
is expanded by one sector, the new area is initialized  to  0, <<06730>>02975000
and  the new subentry is taken from it.  If the segment is al- <<06730>>02980000
ready at its maximum size  (unlikely,  since  this  represents <<06730>>02985000
roughly 500 in-use input or output DFID's), ALLOCENTRY returns <<06730>>02990000
CCL.  Note that ALLOCENTRY merely finds space.  Other routines <<06730>>02995000
are responsible for filling the entry and linking it properly. <<06730>>03000000
                                                               <<06730>>03005000
Inputs:   None.  DB must be at the proper XDS (IDD or ODD) and <<06730>>03010000
          the corresponding SIR must be locked.                <<06730>>03015000
                                                               <<06730>>03020000
Returns:  Segment-relative address of available subentry, or 0 <<06730>>03025000
          (no subentry available, also returns CCL).           <<06730>>03030000
                                                               <<06730>>03035000
Condition code:  CCE -- no errors.                             <<06730>>03040000
                 CCL -- No subentry available.                 <<06730>>03045000
                                                               <<06730>>03050000
System failures:   350 -- Error while expanding XDS.           <<06730>>03055000
                                                               <<06730>>03060000
Special considerations:  DB must be at the IDD or ODD  on  en- <<06730>>03065000
                         try and the corresponding SIR must be <<06730>>03070000
                         locked, same at exit.                 <<06730>>03075000
;                                                              <<06730>>03080000
INTEGER                                                        <<06730>>03085000
   MAX'WORD'ADDRESS,   << Last segment-relative address  in >> <<06730>>03090000
                       << currently-allocated  segment that >> <<06730>>03095000
                       << a subentry can start in.          >> <<06730>>03100000
   STATUS = Q - 1,                                             <<06730>>03105000
   TEMP,                                                       <<06730>>03110000
   XDD'DST;                                                    <<06730>>03115000
                                                               <<06730>>03120000
LOGICAL POINTER                                                <<06730>>03125000
   TEST'ADDRESS;       << Segment-relative offset of candi- >> <<06730>>03130000
                       << date subentry.                    >> <<06730>>03135000
LOGICAL ARRAY                                                  <<06730>>03140000
   XDD(*) = DB + 0;    << Required by XDD $INCLUDE file.    >> <<06730>>03145000
                                                               <<06730>>03150000
                                                               <<06730>>03155000
CC := CCE;                                                     <<06730>>03160000
IF XDD0'IDD'OR'ODD = XDD0'ODD                                  <<06730>>03165000
   THEN XDD'DST := ODD'DST                                     <<06730>>03170000
   ELSE XDD'DST := IDD'DST;                                    <<06730>>03175000
@TEST'ADDRESS := XDD0'SUBENTRY'AREA;                           <<06730>>03180000
MAX'WORD'ADDRESS := XDD0'CURRENT'SECTORS * WORDS'PER'SECTOR    <<06730>>03185000
                    - XDD0'SUBENTRY'LENGTH;                    <<06730>>03190000
WHILE TRUE DO                                                  <<06730>>03195000
      IF @TEST'ADDRESS <= MAX'WORD'ADDRESS THEN                <<06730>>03200000
         IF TEST'ADDRESS = 0 THEN                              <<06730>>03205000
            BEGIN   << Available subentry in current alloc. >> <<06730>>03210000
            ALLOCENTRY := @TEST'ADDRESS;                       <<06730>>03215000
            RETURN;                                            <<06730>>03220000
            END                                                <<06730>>03225000
         ELSE @TEST'ADDRESS := @TEST'ADDRESS +                 <<06730>>03230000
              INTEGER (XDD0'SUBENTRY'LENGTH)                   <<06730>>03235000
      ELSE                                                     <<06730>>03240000
         BEGIN   << All subentries in use, expand table.    >> <<06730>>03245000
         IF XDD0'CURRENT'SECTORS >= XDD0'MAX'SECTORS THEN      <<06730>>03250000
            BEGIN   << No room left to expand.              >> <<06730>>03255000
            ALLOCENTRY := 0;                                   <<06730>>03260000
            CC := CCL;                                         <<06730>>03265000
            RETURN;                                            <<06730>>03270000
            END;                                               <<06730>>03275000
         ALTDSEGSIZE (XDD'DST, WORDS'PER'SECTOR);              <<06730>>03280000
         IF <> THEN SUDDENDEATH (SD350);                       <<07050>>03285000
         XDD (TEMP := XDD0'CURRENT'SECTORS * WORDS'PER'SECTOR) <<06730>>03290000
             := 0;                                             <<06730>>03295000
         MOVE XDD(TEMP+1) := XDD(TEMP), (WORDS'PER'SECTOR-1);  <<06730>>03300000
         XDD0'CURRENT'SECTORS := XDD0'CURRENT'SECTORS + 1;     <<06730>>03305000
         MAX'WORD'ADDRESS := MAX'WORD'ADDRESS +                <<06730>>03310000
             WORDS'PER'SECTOR;                                 <<06730>>03315000
         END;    << All subentries in use, also WHILE loop. >> <<06730>>03320000
END;             << of ALLOCENTRY.                          >> <<06730>>03325000
                                                                        03330000
$PAGE "   ***   DEALLOCENTRY   ***"                            <<06730>>03335000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>03340000
                                                               <<06730>>03345000
PROCEDURE DEALLOCENTRY (XDD'SUBENTRY);                         <<06730>>03350000
   VALUE XDD'SUBENTRY;                                         <<06730>>03355000
   LOGICAL POINTER XDD'SUBENTRY;                               <<06730>>03360000
OPTION PRIVILEGED, UNCALLABLE;                                 <<06730>>03365000
                                                               <<06730>>03370000
BEGIN                                                          <<06730>>03375000
  COMMENT -- DEALLOCENTRY makes an IDD or  ODD  subentry  area <<06730>>03380000
available  once  more  by setting its first word to 0.  (Other <<06730>>03385000
routines must previously have delinked the subentry).  If  re- <<06730>>03390000
leasing  this  subentry makes it possible to decrease the data <<06730>>03395000
segment by one or more sectors, this is also done.             <<06730>>03400000
                                                               <<06730>>03405000
Input:   Segment-relative subentry address.  DB must be at the <<06730>>03410000
         proper XDS (IDD or ODD)  and  the  corresponding  SIR <<06730>>03415000
         must be locked.                                       <<06730>>03420000
                                                               <<06730>>03425000
Returns: None.  Condition code is not affected.                <<06730>>03430000
                                                               <<06730>>03435000
System failures:  351 -- Error while contracting XDS.          <<06730>>03440000
                                                               <<06730>>03445000
Special considerations:  DB must be at the IDD or ODD  on  en- <<06730>>03450000
                         try and the corresponding SIR must be <<06730>>03455000
                         locked, same at exit.                 <<06730>>03460000
;                                                              <<06730>>03465000
INTEGER                                                        <<06730>>03470000
   MAX'WORD'ADDRESS,   << Last segment-relative address  in >> <<06730>>03475000
                       << currently-allocated  segment that >> <<06730>>03480000
                       << a subentry can start in.          >> <<06730>>03485000
   TEMP,                                                       <<06730>>03490000
   XDD'DST;                                                    <<06730>>03495000
                                                               <<06730>>03500000
LOGICAL POINTER                                                <<06730>>03505000
   TEST'ADDRESS;       << Segment-relative offset of candi- >> <<06730>>03510000
                       << date subentry.                    >> <<06730>>03515000
LOGICAL ARRAY                                                  <<06730>>03520000
   XDD(*) = DB + 0;    << Required by XDD $INCLUDE file.    >> <<06730>>03525000
                                                               <<06730>>03530000
IF XDD0'IDD'OR'ODD = XDD0'ODD                                  <<06730>>03535000
   THEN XDD'DST := ODD'DST                                     <<06730>>03540000
   ELSE XDD'DST := IDD'DST;                                    <<06730>>03545000
XDD'SUBENTRY := XDDS'UNUSED'SUBENTRY;   << Make entry avail >> <<06730>>03550000
MAX'WORD'ADDRESS := XDD0'CURRENT'SECTORS * WORDS'PER'SECTOR    <<06730>>03555000
                    - XDD0'SUBENTRY'LENGTH;                    <<06730>>03560000
@TEST'ADDRESS := @XDD'SUBENTRY;                                <<06730>>03565000
WHILE @TEST'ADDRESS <= MAX'WORD'ADDRESS AND                    <<06730>>03570000
   TEST'ADDRESS = XDDS'UNUSED'SUBENTRY DO                      <<06730>>03575000
      @TEST'ADDRESS := @TEST'ADDRESS +                         <<06730>>03580000
         INTEGER (XDD0'SUBENTRY'LENGTH);                       <<06730>>03585000
IF @TEST'ADDRESS > MAX'WORD'ADDRESS THEN                       <<06730>>03590000
   BEGIN                                                       <<06730>>03595000
                                                               <<06730>>03600000
<< Input entry parameter was last one currently in use. See >> <<06730>>03605000
<< if any others are available in front of it.              >> <<06730>>03610000
                                                               <<06730>>03615000
   @TEST'ADDRESS := @XDD'SUBENTRY;                             <<06730>>03620000
   WHILE TEST'ADDRESS = XDDS'UNUSED'SUBENTRY AND               <<06730>>03625000
         @TEST'ADDRESS > INTEGER (XDD0'SUBENTRY'AREA) DO       <<06730>>03630000
      @TEST'ADDRESS := @TEST'ADDRESS -                         <<06730>>03635000
      INTEGER (XDD0'SUBENTRY'LENGTH);                          <<06730>>03640000
   IF TEST'ADDRESS <> XDDS'UNUSED'SUBENTRY THEN                <<06730>>03645000
      @TEST'ADDRESS := @TEST'ADDRESS +                         <<06730>>03650000
                       INTEGER (XDD0'SUBENTRY'LENGTH);         <<06730>>03655000
                                                               <<06730>>03660000
<< @TEST'ADDRESS is now at the start of the next  available >> <<06730>>03665000
<< subentry. See if we recovered enough space to shrink the >> <<06730>>03670000
<< XDS by one or more sectors.                              >> <<06730>>03675000
                                                               <<06730>>03680000
   TEMP := (INTEGER (XDD0'CURRENT'SECTORS) * WORDS'PER'SECTOR  <<06730>>03685000
           - @TEST'ADDRESS) / WORDS'PER'SECTOR;                <<06730>>03690000
   IF TEMP > 0 THEN                                            <<06730>>03695000
      BEGIN   << Can shrink at least one sector.            >> <<06730>>03700000
      XDD0'CURRENT'SECTORS := XDD0'CURRENT'SECTORS -           <<06730>>03705000
           LOGICAL (TEMP);                                     <<06730>>03710000
      ALTDSEGSIZE (XDD'DST, -(TEMP * WORDS'PER'SECTOR));       <<06730>>03715000
      IF <> THEN SUDDENDEATH (SD351);                          <<07050>>03720000
      END;    << Can shrink at least one sector.            >> <<06730>>03725000
   END;   << Input entry parameter was last one in use.     >> <<06730>>03730000
WRITEDSEG'SERIAL (XDD'DST);                                    <<w7889>>03735000
END;      << of DEALLOCENTRY.                               >> <<06730>>03740000
$PAGE "   ***   SLINKXDD   ***"                                <<06730>>03745000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>03750000
                                                                        03755000
PROCEDURE SLINKXDD (HEAD'INDEX, NEW'ENTRY);                    <<06730>>03760000
  VALUE HEAD'INDEX, NEW'ENTRY;                                 <<06730>>03765000
  INTEGER HEAD'INDEX;                                          <<06730>>03770000
  LOGICAL POINTER NEW'ENTRY;                                   <<06730>>03775000
  OPTION PRIVILEGED, UNCALLABLE;                               <<06730>>03780000
BEGIN COMMENT --                                               <<06730>>03785000
  SLINKXDD links the XDD subentry image pointed to by  NEW'EN- <<06730>>03790000
TRY to the subentry chain associated with the head entry indi- <<06730>>03795000
cated by HEAD'INDEX.  If the subentry is an ODD subentry,  its <<06730>>03800000
position in the chain is determined by its output priority (it <<06730>>03805000
goes just before the first subentry of lower priority). If the <<06730>>03810000
subentry is an IDD subentry, it goes at the end of the chain.  <<06730>>03815000
  Once the subentry has been linked, the updated data  segment <<06730>>03820000
is written to the disc.                                        <<06730>>03825000
  There are several possible inconsistencies with this  method <<06730>>03830000
which the previous version of SLINKXDD did not check, no doubt <<06730>>03835000
for performance (speed) reasons since  the  checks  take  more <<06730>>03840000
time  per  link than the search and the problems only arise if <<06730>>03845000
the XDD has been corrupted.  However, I feel that this is time <<06730>>03850000
well spent if it will help insure the integrity of the XDD. We <<06730>>03855000
only come here when opening, closing or altering a devicefile, <<06730>>03860000
so we won't lose much time overall.                            <<06730>>03865000
  The inconsistencies (any of which result in SF 354) are:     <<06730>>03870000
1.  The first word of NEW'ENTRY is 0, signifying that the sub- <<06730>>03875000
    entry is currently not in use.                             <<06730>>03880000
2.  NEW'ENTRY is not a part of the chain defined  by  HEAD'IN- <<06730>>03885000
    DEX.  This is checked by examining the head index field of <<06730>>03890000
    NEW'ENTRY and comparing it to HEAD'INDEX.                  <<06730>>03895000
3.  While searching the links, we link to an area outside  the <<07050>>03900000
    currently-defined  XDD  subentry  area or exceed the total <<07050>>03905000
    number of subentries in the table  (signifies  an  endless <<07050>>03910000
    loop).                                                     <<07050>>03915000
                                                               <<06730>>03920000
Inputs:   HEAD'INDEX.  Defines the chain (LDEV  or  class)  to <<06730>>03925000
          which NEW'ENTRY is linked.                           <<06730>>03930000
                                                               <<06730>>03935000
          NEW'ENTRY.  The subentry image to be linked  to  the <<06730>>03940000
          HEAD'INDEX chain.                                    <<06730>>03945000
                                                               <<06730>>03950000
Returns:  None.  The condition code is not affected.           <<06730>>03955000
                                                               <<06730>>03960000
System failures:  354 -- see comments.                         <<06730>>03965000
                                                               <<06730>>03970000
Special considerations:  DB must be at the IDD or ODD  on  en- <<06730>>03975000
                         try and the corresponding SIR must be <<06730>>03980000
                         locked, same at exit.                 <<06730>>03985000
;                                                              <<06730>>03990000
LOGICAL ARRAY                                                  <<06730>>03995000
   XDD(*) = DB + 0;    << Required by XDD $INCLUDE file.    >> <<06730>>04000000
                                                               <<06730>>04005000
LOGICAL POINTER                                                <<06730>>04010000
   XDD'HEAD,           << Required by XDD $INCLUDE file.    >> <<06730>>04015000
   XDD'SUBENTRY;       << Required by XDD $INCLUDE file.    >> <<06730>>04020000
                                                               <<06730>>04025000
LOGICAL                                                        <<06730>>04030000
   FOUND'IT := FALSE;                                          <<06730>>04035000
                                                               <<06730>>04040000
INTEGER                                                        <<06730>>04045000
   ENTRY'COUNT := 0, << Count of checked subentry links.    >> <<07050>>04050000
   ENTRY'LIMIT     , << Max # links (to prevent looping).   >> <<07330>>04055000
   MAX'WORD'ADDRESS, << Last  segment-relative  address  in >> <<07050>>04060000
                     << currently-allocated  segment that a >> <<07050>>04065000
                     << subentry can start in.              >> <<07050>>04070000
   NEW'OUTPRI,                                                 <<06730>>04075000
   NEXT'ENTRY,       << Used during link search.            >> <<06730>>04080000
   PREVIOUS'ENTRY := -1,   << This too.                     >> <<06730>>04085000
   XDD'DST;                                                    <<06730>>04090000
                                                               <<06730>>04095000
@XDD'HEAD := HEAD'INDEX * INTEGER (XDD0'HEAD'LENGTH);          <<06730>>04100000
@XDD'SUBENTRY := @NEW'ENTRY;                                   <<06730>>04105000
IF XDD0'IDD'OR'ODD = XDD0'ODD THEN                             <<06730>>04110000
   BEGIN   << ODD, scan links looking for lower priority.   >> <<06730>>04115000
   XDD'DST := ODD'DST;                                         <<06730>>04120000
   NEXT'ENTRY := XDDH'FIRST'SUBENTRY;                          <<07050>>04125000
   IF INTEGER (XDDS'HEAD'INDEX) <> HEAD'INDEX OR               <<06730>>04130000
      XDD'SUBENTRY = XDDS'UNUSED'SUBENTRY THEN                 <<06730>>04135000
      SUDDENDEATH (SD354);                                     <<07050>>04140000
   NEW'OUTPRI := XDDS'OUTPUT'PRIORITY;                         <<06730>>04145000
   MAX'WORD'ADDRESS := XDD0'CURRENT'SECTORS * WORDS'PER'SECTOR <<07050>>04150000
                       - XDD0'SUBENTRY'LENGTH;                 <<07050>>04155000
   ENTRY'LIMIT := (LOGICAL (MAX'WORD'ADDRESS) -                <<07330>>04160000
                   XDD0'SUBENTRY'AREA) / XDD0'SUBENTRY'LENGTH  <<07330>>04165000
                   + 1;                                        <<07330>>04170000
   WHILE NEXT'ENTRY <> XDDS'END'OF'CHAIN AND NOT FOUND'IT DO   <<06730>>04175000
      BEGIN   << Compare priorities at this link.           >> <<06730>>04180000
      IF NEXT'ENTRY > MAX'WORD'ADDRESS OR                      <<07330>>04185000
         NEXT'ENTRY < INTEGER (XDD0'SUBENTRY'AREA) THEN        <<06730>>04190000
         SUDDENDEATH (SD354);   << Outside subentry area.   >> <<07050>>04195000
      @XDD'SUBENTRY := NEXT'ENTRY;                             <<06730>>04200000
      IF INTEGER (XDDS'OUTPUT'PRIORITY) >= NEW'OUTPRI THEN     <<06730>>04205000
         BEGIN   << Link not found yet, advance to next one >> <<06730>>04210000
         PREVIOUS'ENTRY := NEXT'ENTRY;                         <<06730>>04215000
         NEXT'ENTRY := XDDS'NEXT'SUBENTRY;                     <<06730>>04220000
         IF (ENTRY'COUNT := ENTRY'COUNT + 1) > ENTRY'LIMIT     <<07050>>04225000
            THEN SUDDENDEATH (SD354);  << Stop endless loop >> <<07050>>04230000
         END                                                   <<06730>>04235000
      ELSE FOUND'IT := TRUE;                                   <<06730>>04240000
      END;   << of WHILE loop.                              >> <<06730>>04245000
   END       << of ODD case.                                >> <<06730>>04250000
ELSE                                                           <<06730>>04255000
   BEGIN     << IDD, put new subentry at tail.              >> <<06730>>04260000
   XDD'DST := IDD'DST;                                         <<06730>>04265000
   IF XDD'SUBENTRY = XDDS'UNUSED'SUBENTRY THEN                 <<06730>>04270000
      SUDDENDEATH (SD354);                                     <<07050>>04275000
   IF INTEGER (XDDH'LAST'SUBENTRY) <> @XDDH'FIRST'SUBENTRY     <<06730>>04280000
      THEN PREVIOUS'ENTRY := XDDH'LAST'SUBENTRY;               <<06730>>04285000
   NEXT'ENTRY := XDDS'END'OF'CHAIN;                            <<06730>>04290000
   END;      << of IDD case.                                >> <<06730>>04295000
IF PREVIOUS'ENTRY = -1 THEN                                    <<06730>>04300000
   XDDH'FIRST'SUBENTRY := @NEW'ENTRY; << Linking at head.   >> <<06730>>04305000
IF NEXT'ENTRY = XDDS'END'OF'CHAIN THEN                         <<06730>>04310000
   XDDH'LAST'SUBENTRY := @NEW'ENTRY;  << Linking at tail.   >> <<06730>>04315000
@XDD'SUBENTRY := @NEW'ENTRY;                                   <<06730>>04320000
XDDS'NEXT'SUBENTRY := NEXT'ENTRY;     << New "next" link.   >> <<06730>>04325000
IF INTEGER (XDDH'FIRST'SUBENTRY) <> @NEW'ENTRY THEN            <<06730>>04330000
   BEGIN   << New "prior" link if not at head of queue.     >> <<06730>>04335000
   @XDD'SUBENTRY := PREVIOUS'ENTRY;                            <<06730>>04340000
   XDDS'NEXT'SUBENTRY := @NEW'ENTRY;                           <<06730>>04345000
   END;    << New "prior" link.                             >> <<06730>>04350000
WRITEDSEG'SERIAL (XDD'DST);                                    <<w7889>>04355000
END;       << of SLINKXDD                                   >> <<06730>>04360000
$PAGE "   ***   DELINKENTRY   ***"                             <<06730>>04365000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>04370000
                                                                        04375000
PROCEDURE DELINKENTRY (HEAD'POINTER, OLD'SUBENTRY);            <<06730>>04380000
   VALUE OLD'SUBENTRY;                                         <<06730>>04385000
   LOGICAL POINTER HEAD'POINTER, OLD'SUBENTRY;                 <<06730>>04390000
   OPTION PRIVILEGED, UNCALLABLE;                              <<06730>>04395000
BEGIN COMMENT --                                               <<06730>>04400000
  DELINKENTRY delinks OLD'SUBENTRY from the  chain  of  suben- <<06730>>04405000
tries starting at the address in HEAD'POINTER. The subentry is <<06730>>04410000
not modified (the caller may want  to  relink  it  to  another <<06730>>04415000
chain).  The  chain is then relinked around the deleted suben- <<06730>>04420000
try.  If the subentry being delinked is either the head or the <<06730>>04425000
tail subentry (or both if it is the only one), the appropriate <<06730>>04430000
pointers in the head entry are also updated.                   <<06730>>04435000
  The subentry chain is searched, starting with the address in <<06730>>04440000
HEAD'POINTER and continuing through the links, until  OLD'SUB- <<06730>>04445000
ENTRY  is  found.  There  are several possible inconsistencies <<06730>>04450000
with this method which the previous version of DELINKENTRY did <<06730>>04455000
not check, no doubt for performance (speed) reasons since  the <<06730>>04460000
checks  take  more time per link than the search and the prob- <<06730>>04465000
lems only arise if the XDD has been corrupted. However, I feel <<06730>>04470000
that this is time well spent if it will help assure the integ- <<06730>>04475000
rity of the XDD.  We only come here when opening,  closing  or <<06730>>04480000
altering a devicefile, so we won't lose much time overall.     <<06730>>04485000
  The inconsistencies (any of which result in SF 354 are):     <<06730>>04490000
1.  OLD'SUBENTRY is not a part of the chain defined  by  HEAD' <<06730>>04495000
    POINTER. This is checked by examining the head index field <<06730>>04500000
    of OLD'SUBENTRY and comparing it to  HEAD'POINTER.  It  is <<06730>>04505000
    also  established  if  we  search  the entire HEAD'POINTER <<06730>>04510000
    chain without matching OLD'SUBENTRY.                       <<06730>>04515000
2.  While searching the links, we link to an area outside  the <<07050>>04520000
    currently-defined  XDD  subentry  area, discover an unused <<07050>>04525000
    (but linked) subentry, or exceed the total number of  sub- <<07050>>04530000
    entries in the table (signifies an endless loop).          <<07050>>04535000
                                                               <<06730>>04540000
Inputs:   HEAD'POINTER. The head entry word containing the ad- <<06730>>04545000
          dress of the first subentry in the chain.  NOTE: not <<06730>>04550000
          the head index or the address of  the  corresponding <<06730>>04555000
          head entry, but the address of the head pointer word <<06730>>04560000
          in the head entry.                                   <<06730>>04565000
                                                               <<06730>>04570000
          OLD'SUBENTRY.  The segment-relative address  of  the <<06730>>04575000
          subentry to be delinked.                             <<06730>>04580000
                                                               <<06730>>04585000
Returns:  Updated head and tail  pointer,  if  any,  in  HEAD' <<06730>>04590000
          POINTER.  Condition code is not affected.            <<06730>>04595000
                                                               <<06730>>04600000
System failures:  354 -- see comments.                         <<06730>>04605000
                                                               <<06730>>04610000
Special considerations:  DB must be at the IDD or ODD  on  en- <<06730>>04615000
                         try and the corresponding SIR must be <<06730>>04620000
                         locked, same at exit.                 <<06730>>04625000
                                                               <<06730>>04630000
Ways and means:  We need the local variable I'HEAD'POINTER  to <<06730>>04635000
                 get the address of HEAD'POINTER. I don't like <<06730>>04640000
                 this method, but it impossible to get the ad- <<06730>>04645000
                 dress of a reference  parameter  pointer  any <<06730>>04650000
                 other way.                                    <<06730>>04655000
;                                                              <<06730>>04660000
INTEGER                                                        <<06730>>04665000
   ENTRY'COUNT := 0, << Count of checked subentry links.    >> <<07050>>04670000
   ENTRY'LIMIT     , << Max # links (to prevent looping).   >> <<07330>>04675000
   I'HEAD'POINTER = HEAD'POINTER,                              <<06730>>04680000
   MAX'WORD'ADDRESS, << Last  segment-relative  address  in >> <<07050>>04685000
                     << currently-allocated  segment that a >> <<07050>>04690000
                     << subentry can start in.              >> <<07050>>04695000
   NEXT'ENTRY,       << Used during link search.            >> <<06730>>04700000
   OLD'NEXT'LINK,    << Link word from OLD'SUBENTRY.        >> <<06730>>04705000
   PREVIOUS'ENTRY := -1;   << Used during link search.      >> <<06730>>04710000
                                                               <<06730>>04715000
LOGICAL ARRAY                                                  <<06730>>04720000
   XDD(*) = DB + 0;    << Required by XDD $INCLUDE file.    >> <<06730>>04725000
                                                               <<06730>>04730000
LOGICAL POINTER                                                <<06730>>04735000
   XDD'HEAD,           << Required by XDD $INCLUDE file.    >> <<06730>>04740000
   XDD'SUBENTRY;       << This one too.                     >> <<06730>>04745000
                                                               <<06730>>04750000
                                                               <<06730>>04755000
@XDD'SUBENTRY := @OLD'SUBENTRY;                                <<06730>>04760000
@XDD'HEAD := XDDS'HEAD'INDEX * XDD0'HEAD'LENGTH;               <<06730>>04765000
IF I'HEAD'POINTER <> @XDDH'FIRST'SUBENTRY THEN                 <<06730>>04770000
   SUDDENDEATH (SD354);                                        <<07050>>04775000
OLD'NEXT'LINK := XDDS'NEXT'SUBENTRY;                           <<06730>>04780000
NEXT'ENTRY := XDDH'FIRST'SUBENTRY;                             <<07050>>04785000
MAX'WORD'ADDRESS := XDD0'CURRENT'SECTORS * WORDS'PER'SECTOR    <<07050>>04790000
                    - XDD0'SUBENTRY'LENGTH;                    <<07050>>04795000
ENTRY'LIMIT := (LOGICAL (MAX'WORD'ADDRESS) -                   <<07330>>04800000
                XDD0'SUBENTRY'AREA) / XDD0'SUBENTRY'LENGTH     <<07330>>04805000
                + 1;                                           <<07330>>04810000
                                                               <<06730>>04815000
WHILE NEXT'ENTRY <> @OLD'SUBENTRY DO                           <<06730>>04820000
   BEGIN   << Search links looking for match.               >> <<06730>>04825000
   IF NEXT'ENTRY > MAX'WORD'ADDRESS OR                         <<07330>>04830000
      NEXT'ENTRY < INTEGER (XDD0'SUBENTRY'AREA) OR             <<06730>>04835000
      NEXT'ENTRY = XDDS'END'OF'CHAIN THEN SUDDENDEATH (SD354); <<07050>>04840000
   @XDD'SUBENTRY := PREVIOUS'ENTRY := NEXT'ENTRY;              <<06730>>04845000
   IF XDD'SUBENTRY = XDDS'UNUSED'SUBENTRY THEN                 <<06730>>04850000
      SUDDENDEATH (SD354);                                     <<07050>>04855000
   NEXT'ENTRY := XDDS'NEXT'SUBENTRY;                           <<06730>>04860000
   IF (ENTRY'COUNT := ENTRY'COUNT + 1) > ENTRY'LIMIT THEN      <<07050>>04865000
      SUDDENDEATH (SD354);   << Stop endless loop.          >> <<07050>>04870000
   END;                                                        <<06730>>04875000
                                                               <<06730>>04880000
<< Found our subentry, now adjust links and pointers.       >> <<06730>>04885000
                                                               <<06730>>04890000
IF PREVIOUS'ENTRY = -1 THEN                                    <<06730>>04895000
   BEGIN   << Delinking first or only subentry.             >> <<06730>>04900000
   XDDH'FIRST'SUBENTRY := OLD'NEXT'LINK;                       <<06730>>04905000
   IF OLD'NEXT'LINK = XDDS'END'OF'CHAIN THEN                   <<06730>>04910000
      XDDH'LAST'SUBENTRY := @XDDH'FIRST'SUBENTRY;  << Only  >> <<06730>>04915000
   END                                                         <<06730>>04920000
ELSE                                                           <<06730>>04925000
   BEGIN   << Not first subentry, may be last.              >> <<06730>>04930000
   @XDD'SUBENTRY := PREVIOUS'ENTRY;                            <<06730>>04935000
   XDDS'NEXT'SUBENTRY := OLD'NEXT'LINK;                        <<06730>>04940000
   IF OLD'NEXT'LINK = XDDS'END'OF'CHAIN THEN                   <<06730>>04945000
      XDDH'LAST'SUBENTRY := PREVIOUS'ENTRY;  << Last subntry>> <<06730>>04950000
   END;                                                        <<06730>>04955000
END;   << of DELINKENTRY.                                   >> <<06730>>04960000
$PAGE "   ***   SRELINKODD   ***"                              <<06730>>04965000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>04970000
                                                               <<06730>>04975000
PROCEDURE SRELINKODD (XDD'SUBENTRY, NEWDEV);                   <<06730>>04980000
   VALUE   XDD'SUBENTRY, NEWDEV;                               <<06730>>04985000
   INTEGER NEWDEV;                                             <<06730>>04990000
   LOGICAL POINTER XDD'SUBENTRY;                               <<06730>>04995000
   OPTION PRIVILEGED, UNCALLABLE;                              <<06730>>05000000
BEGIN COMMENT --                                               <<06730>>05005000
  SRELINKODD relinks the ODD subentry beginning at ODD segment <<06730>>05010000
relative address XDD'SUBENTRY to the chain specified  by  NEW- <<06730>>05015000
DEV.  If  NEWDEV < 0 it is taken as a Device Class Table index <<06730>>05020000
and XDD'SUBENTRY is relinked to the ODD class chain.           <<06730>>05025000
                                                               <<06730>>05030000
Inputs:   XDD'SUBENTRY.  ODD segment-relative address  of  the <<06730>>05035000
          first  word  of  the subentry to be relinked.  NOTE: <<06730>>05040000
          The XDD $INCLUDE file requires this symbol.          <<06730>>05045000
                                                               <<06730>>05050000
          NEWDEV.  The new chain to which XDD'SUBENTRY  is  to <<06730>>05055000
          be  linked, if > 0 the associated LDEV chain, if < 0 <<06730>>05060000
          the ODD class chain.                                 <<06730>>05065000
                                                               <<06730>>05070000
Returns:  None.  The condition code is not affected.           <<06730>>05075000
                                                               <<06730>>05080000
System failures:  352 -- The ODD is inconsistent with the LDT. <<06730>>05085000
                                                               <<06730>>05090000
Special consideration:  DB may be anywhere at entry,  same  at <<06730>>05095000
                        exit.                                  <<06730>>05100000
;                                                              <<06730>>05105000
INTEGER                                                        <<06730>>05110000
   DST'AT'ENTRY := -1,                                         <<06730>>05115000
   HEAD'INDEX,                                                 <<06730>>05120000
   LDT'INDEX,                                                  <<06730>>05125000
   PCBPT,             << Required by PCB $INCLUDE file.     >> <<06730>>05130000
   SAVE'LDT'SIR,                                               <<06730>>05135000
   SAVE'ODD'SIR,                                               <<06730>>05140000
   SPOOL'STATE,                                                <<06730>>05145000
   VIRTUAL'DEVICE;                                             <<06730>>05150000
                                                               <<06730>>05155000
LOGICAL ARRAY                                                  <<06730>>05160000
   XDD(*) = DB + 0;   << Required by XDD $INCLUDE file.     >> <<06730>>05165000
                                                               <<06730>>05170000
LOGICAL POINTER                                                <<06730>>05175000
   LDT,               << Required by LDT $INCLUDE file.     >> <<06730>>05180000
   PCB = SYSPCBINDEX, << Required by PCB $INCLUDE file.     >> <<06730>>05185000
   XDD'HEAD;          << Required by XDD $INCLUDE file.     >> <<06730>>05190000
                                                               <<06730>>05195000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>05200000
                                                               <<06730>>05205000
IF NEWDEV = 0 THEN RETURN;                                     <<06730>>05210000
PCBPT := CURPRC;      << Required by PCB $INCLUDE file.     >> <<06730>>05215000
SAVE'LDT'SIR := GETSIR (LDT'SIR);                              <<06730>>05220000
SAVE'ODD'SIR := GETSIR (ODD'SIR);                              <<06730>>05225000
IF SPCBXDSDST <> ODD'DST THEN                                  <<06730>>05230000
   DST'AT'ENTRY := EXCHANGEDB (ODD'DST);                       <<06730>>05235000
@XDD'HEAD := XDDS'HEAD'INDEX * XDD0'HEAD'LENGTH;               <<06730>>05240000
TOS := @XDDH'FIRST'SUBENTRY;   << Can't fool SPL...         >> <<06730>>05245000
DELINKENTRY (*, XDD'SUBENTRY); <<   any other way.          >> <<06730>>05250000
VIRTUAL'DEVICE := XDDS'VIRTUAL'LDEV;                           <<06730>>05255000
SPOOL'STATE := XDDS'SPOOL'STATE;                               <<06730>>05260000
EXCHANGEDB (LDT'DST);                                          <<06730>>05265000
@LDT := 0;                                                     <<06730>>05270000
LDT'INDEX := NEWDEV * INTEGER (LDT'ENTRY'SIZE);                <<06730>>05275000
IF NEWDEV > 0                                                  <<06730>>05280000
   THEN HEAD'INDEX := LDT'XDD'HEAD'INDEX                       <<06730>>05285000
   ELSE HEAD'INDEX := XDD'CLASS'INDEX;                         <<06730>>05290000
IF SPOOL'STATE = XDDS'OPEN AND VIRTUAL'DEVICE <> 0 THEN        <<06730>>05295000
   BEGIN   << Update XDD index in LDT virtual device entry. >> <<06730>>05300000
   LDT'INDEX := VIRTUAL'DEVICE * INTEGER (LDT'ENTRY'SIZE);     <<06730>>05305000
   LDT'XDD'HEAD'INDEX := HEAD'INDEX;                           <<06730>>05310000
   END;                                                        <<06730>>05315000
EXCHANGEDB (ODD'DST);                                          <<06730>>05320000
IF NEWDEV > 0 THEN                                             <<06730>>05325000
   BEGIN   << Consistency check between LDT and ODD.        >> <<06730>>05330000
   @XDD'HEAD := HEAD'INDEX * INTEGER (XDD0'HEAD'LENGTH);       <<06730>>05335000
   IF INTEGER (XDDH'LDEV) <> NEWDEV THEN SUDDENDEATH (SD352);  <<07050>>05340000
   END;                                                        <<06730>>05345000
XDDS'CLASS := (NEWDEV < 0);                                    <<06730>>05350000
XDDS'DEVICE := \NEWDEV\;                                       <<06730>>05355000
XDDS'HEAD'INDEX := HEAD'INDEX;                                 <<06730>>05360000
SLINKXDD (HEAD'INDEX, XDD'SUBENTRY);                           <<06730>>05365000
IF DST'AT'ENTRY <> -1 THEN EXCHANGEDB (DST'AT'ENTRY);          <<06730>>05370000
RELSIR (ODD'SIR, SAVE'ODD'SIR);                                <<06730>>05375000
RELSIR (LDT'SIR, SAVE'LDT'SIR);                                <<06730>>05380000
END;   << of SRELINKODD.                                    >> <<06730>>05385000
$PAGE "   ***   SPUTXDD   ***"                                 <<06730>>05390000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>05395000
                                                                        05400000
INTEGER PROCEDURE SPUTXDD (ODD, DEVICE, NEW'SUBENTRY,          <<06730>>05405000
                           XDD'ADDRESS);                       <<06730>>05410000
   VALUE   ODD, DEVICE;                                        <<06730>>05415000
   LOGICAL ODD;                                                <<06730>>05420000
   INTEGER DEVICE;                                             <<06730>>05425000
   LOGICAL ARRAY NEW'SUBENTRY;                                 <<06730>>05430000
   LOGICAL POINTER XDD'ADDRESS;                                <<06730>>05435000
   OPTION  PRIVILEGED, UNCALLABLE;                             <<06730>>05440000
                                                               <<06730>>05445000
BEGIN COMMENT --                                               <<06730>>05450000
  SPUTXDD takes an XDD subentry image (NEW'SUBENTRY) built and <<06730>>05455000
partially filled by the caller. It fills some more fields, ac- <<06730>>05460000
quires space for it in the appropriate table (IDD or ODD), and <<06730>>05465000
links the subentry into the appropriate device or class chain. <<06730>>05470000
                                                               <<06730>>05475000
Inputs:   ODD. TRUE if the subentry is to go in the ODD, FALSE <<06730>>05480000
          if it goes in the IDD.                               <<06730>>05485000
                                                               <<06730>>05490000
          DEVICE.  If > 0, a logical device number.  If < 0, a <<06730>>05495000
          Device Class Table index.  0 is not allowed  (causes <<06730>>05500000
          a system failure).                                   <<06730>>05505000
                                                               <<06730>>05510000
          NEW'SUBENTRY.  The image of the  subentry  which  we <<06730>>05515000
          will insert into the XDD.                            <<06730>>05520000
                                                               <<06730>>05525000
Returns:  XDD'ADDRESS.(1:15): The XDD segment-relative address <<06730>>05530000
          where the subentry was placed, or 0 if there was  no <<06730>>05535000
          room in the segment.                                 <<06730>>05540000
                                                               <<06730>>05545000
          XDD'ADDRESS.(0:1):  1 if this is an ODD subentry,  0 <<06730>>05550000
          if  this  is an IDD subentry or if SPUTXDD indicates <<06730>>05555000
          no room in the XDD.                                  <<06730>>05560000
                                                               <<06730>>05565000
          SPUTXDD.  0 -- No error, 1 -- no room in XDD.        <<06730>>05570000
                                                               <<06730>>05575000
          The condition code is not affected.                  <<06730>>05580000
                                                               <<06730>>05585000
System failure:  353 -- The XDD is inconsistent with the  LDT, <<06730>>05590000
                        -OR- the DEVICE parameter = 0.         <<06730>>05595000
                                                               <<06730>>05600000
Special considerations:  DB must be at  the  stack  at  entry, <<06730>>05605000
                         same at exit.                         <<06730>>05610000
                                                               <<06730>>05615000
Ways and means:  After we get space for the subentry, we  must <<06730>>05620000
                 move  the  NEW'SUBENTRY image into the space. <<06730>>05625000
                 But NEW'SUBENTRY is stack DB-relative,  while <<06730>>05630000
                 DB is then at the XDD. Using a rather bizarre <<06730>>05635000
                 application of MOVEFROMDSEG, we move FROM the <<06730>>05640000
                 stack data segment TO the XDD-relative suben- <<06730>>05645000
                 try area.  Since DB is not at the base of the <<06730>>05650000
                 stack data segment, we must obtain the offset <<06730>>05655000
                 before setting DB to the XDD.                 <<06730>>05660000
                   The XDD revision for MPE V gives us a  real <<07050>>05665000
                 headache  --  we have to more the LDEV/Device <<07050>>05670000
                 Class Index field out of word 0 to expand  it <<07050>>05675000
                 to 16 bits.  The remaining eight bits can all <<07050>>05680000
                 be 0 (an ACTIVE input file to an LDEV (as op- <<07050>>05685000
                 posed to a class) at priority 0).  But we use <<07050>>05690000
                 a 0 in this word to test for an unused suben- <<07050>>05695000
                 try.  While the LDEV/Device Class  Index  was <<07050>>05700000
                 there we were safe (never use LDEV or DCI 0). <<07050>>05705000
                 To avoid this problem without changing sever- <<07050>>05710000
                 al modules, SPUTXDD will stuff a non-0  value <<07050>>05715000
                 in this unused field.                         <<07050>>05720000
;                                                              <<06730>>05725000
$PAGE                                                          <<06730>>05730000
EQUATE                                                         <<06730>>05735000
   NO'ERROR = 0,   << SPUTXDD                               >> <<06730>>05740000
   NO'ROOM  = 1;   <<   result values.                      >> <<06730>>05745000
                                                               <<06730>>05750000
LOGICAL ARRAY                                                  <<06730>>05755000
   QARRAY(*) = Q + 0, << Required by PXGLOBAL $INCLUDE file >> <<06730>>05760000
   LDT(0:SIZE'OF'LDT'ENTRY-1),                                 <<06730>>05765000
   XDD(*) = DB + 0;   << Required by XDD $INCLUDE file.     >> <<06730>>05770000
                                                               <<06730>>05775000
LOGICAL POINTER                                                <<06730>>05780000
   PCB = SYSPCBINDEX, << Required by PCB $INCLUDE file.     >> <<06730>>05785000
   XDD'HEAD,          << Required by XDD $INCLUDE file.     >> <<06730>>05790000
   XDD'SUBENTRY;      << This one too.                      >> <<06730>>05795000
                                                               <<06730>>05800000
INTEGER                                                        <<06730>>05805000
   DB'OFFSET,         << from stack segment base to DB.     >> <<06730>>05810000
   HEAD'INDEX,                                                 <<06730>>05815000
   LDT'INDEX := 0,    << Required by LDT $INCLUDE file.     >> <<06730>>05820000
   PCBPT,             << Required by PCB $INCLUDE file.     >> <<06730>>05825000
   PCBGLOBLOC,        << Required by PXGLOBAL $INCLUDE file >> <<06730>>05830000
   Q'NEW'SUBENTRY,    << For use later with DB at XDD.      >> <<06730>>05835000
   SAVE'XDD'SIR,                                               <<06730>>05840000
   XDD'DST,                                                    <<06730>>05845000
   XDD'SIR;                                                    <<06730>>05850000
                                                               <<06730>>05855000
                                                               <<06730>>05860000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>05865000
                                                               <<06730>>05870000
                                                               <<06730>>05875000
PXGLOBAL;             << Required by PXGLOBAL $INCLUDE file >> <<06730>>05880000
DB'OFFSET := PXG'RELATIVE'DB;                                  <<06730>>05885000
PCBPT := CURPRC;      << Required by PCB $INCLUDE file.     >> <<06730>>05890000
Q'NEW'SUBENTRY := @NEW'SUBENTRY;                               <<06730>>05895000
IF DEVICE = 0 THEN SUDDENDEATH (SD353);   << Don't DO that! >> <<07050>>05900000
IF ODD THEN                                                    <<06730>>05905000
   BEGIN                                                       <<06730>>05910000
   XDD'DST := ODD'DST;                                         <<06730>>05915000
   XDD'SIR := ODD'SIR;                                         <<06730>>05920000
   END                                                         <<06730>>05925000
ELSE                                                           <<06730>>05930000
   BEGIN                                                       <<06730>>05935000
   XDD'DST := IDD'DST;                                         <<06730>>05940000
   XDD'SIR := IDD'SIR;                                         <<06730>>05945000
   END;                                                        <<06730>>05950000
                                                               <<06730>>05955000
IF DEVICE  < 0 THEN   << Device Class Table index.          >> <<06730>>05960000
   HEAD'INDEX := XDD'CLASS'INDEX                               <<06730>>05965000
ELSE                                                           <<06730>>05970000
   BEGIN              << Logical device number.             >> <<06730>>05975000
   MOVEFROMDSEG (@LDT, LDT'DST, DEVICE * SIZE'OF'LDT'ENTRY,    <<06730>>05980000
                 SIZE'OF'LDT'ENTRY);                           <<06730>>05985000
   HEAD'INDEX := LDT'XDD'HEAD'INDEX;                           <<06730>>05990000
   END;                                                        <<06730>>05995000
EXCHANGEDB (XDD'DST);                                          <<06730>>06000000
IF DEVICE > 0 THEN                                             <<06730>>06005000
   BEGIN   << Consistency check between XDD and LDT.        >> <<06730>>06010000
   @XDD'HEAD := HEAD'INDEX * INTEGER (XDD0'HEAD'LENGTH);       <<06730>>06015000
   IF INTEGER (XDDH'LDEV) <> DEVICE THEN SUDDENDEATH (SD353);  <<07050>>06020000
   END;                                                        <<06730>>06025000
SAVE'XDD'SIR := GETSIR (XDD'SIR);                              <<06730>>06030000
@XDD'SUBENTRY := ALLOCENTRY;   << Try to get XDD space      >> <<06730>>06035000
IF = THEN                      <<   for new subentry.       >> <<06730>>06040000
   BEGIN                                                       <<06730>>06045000
                                                               <<06730>>06050000
<< Got the space, now move subentry into it.  Subentry  was >> <<06730>>06055000
<< partially initialized at entry.  We fill some more of it >> <<06730>>06060000
<< (but not all the rest) here.  This is where we  set  the >> <<07050>>06065000
<< unused  field  of word 0 to non-0 so that other routines >> <<07050>>06070000
<< will always know the subentry is in use.                 >> <<07050>>06075000
<<         *-*-*   C-A-U-T-I-O-N:    *-*-*                  >> <<07050>>06080000
<< This fix is over and above the XDD $INCLUDE file defini- >> <<07050>>06085000
<< tion. If the XDD is ever revised to use this field, this >> <<07050>>06090000
<< code must also be changed.                               >> <<07050>>06095000
                                                               <<06730>>06100000
   MOVEFROMDSEG (@XDD'SUBENTRY, SPCBSTKDST,                    <<06730>>06105000
       DB'OFFSET + Q'NEW'SUBENTRY, XDD0'SUBENTRY'LENGTH);      <<06730>>06110000
   XDD'SUBENTRY.(8:8) := 1;   << Any non-0 value will do.   >> <<07050>>06115000
   XDDS'CLASS := (DEVICE < 0);                                 <<06730>>06120000
   XDDS'DEVICE := \DEVICE\;                                    <<06730>>06125000
   XDDS'DFID'NUMBER := XDD0'NEXT'DFID;                         <<06730>>06130000
   XDDS'DFID'IN'OR'OUT := ODD;                                 <<06730>>06135000
   XDD0'NEXT'DFID := XDD0'NEXT'DFID + 1;                       <<06730>>06140000
   IF XDD0'NEXT'DFID = 0 THEN XDD0'NEXT'DFID := 1;             <<06730>>06145000
   XDDS'HEAD'INDEX := HEAD'INDEX;                              <<06730>>06150000
                                                               <<06730>>06155000
<< Link the subentry into the proper (device/class) chain.  >> <<06730>>06160000
                                                               <<06730>>06165000
   SLINKXDD (HEAD'INDEX, XDD'SUBENTRY);                        <<06730>>06170000
                                                               <<06730>>06175000
<< We need the TOS's below to avoid the split-stack trap -- >> <<06730>>06180000
<< stuffing a stack DB-relative reference parameter  (@XDD' >> <<06730>>06185000
<< ADDRESS with DB not at the stack (still at the XDD here. >> <<06730>>06190000
                                                               <<06730>>06195000
   TOS := LOGICAL (@XDD'SUBENTRY) LOR (ODD & LSL(15));         <<06730>>06200000
   SPUTXDD := NO'ERROR;                                        <<06730>>06205000
   END                                                         <<06730>>06210000
ELSE                                                           <<06730>>06215000
   BEGIN   << ALLOCENTRY failed, no room left in XDD.       >> <<06730>>06220000
   TOS := 0;                                                   <<06730>>06225000
   SPUTXDD := NO'ROOM;                                         <<06730>>06230000
   END;                                                        <<06730>>06235000
RELSIR (XDD'SIR, SAVE'XDD'SIR);                                <<06730>>06240000
EXCHANGEDB (STACK);                                            <<06730>>06245000
@XDD'ADDRESS := TOS;   << Safe to return this now.          >> <<06730>>06250000
END;       << of SPUTXDD.                                   >> <<06730>>06255000
$PAGE "   ***   SREMOVEXDD   ***"                              <<06730>>06260000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>06265000
                                                                        06270000
PROCEDURE SREMOVEXDD (XDD'SUBENTRY);                           <<06730>>06275000
   VALUE XDD'SUBENTRY;                                         <<06730>>06280000
   LOGICAL POINTER XDD'SUBENTRY;                               <<06730>>06285000
   OPTION  PRIVILEGED, UNCALLABLE;                             <<06730>>06290000
                                                               <<06730>>06295000
BEGIN COMMENT --                                               <<06730>>06300000
  SREMOVEXDD delinks XDD'SUBENTRY from its  head  entry  chain <<06730>>06305000
and deallocates its subentry space.                            <<06730>>06310000
                                                               <<06730>>06315000
Inputs:   XDD'SUBENTRY.(1:15) -- The XDD segment-relative  ad- <<06730>>06320000
          dress of the subentry to be deleted.                 <<06730>>06325000
                                                               <<06730>>06330000
          XDD'SUBENTRY.(0:1) -- 1 if this is an ODD  subentry, <<06730>>06335000
          0 if this is an IDD subentry.                        <<06730>>06340000
                                                               <<06730>>06345000
          NOTE:  The XDD $INCLUDE file requires this symbol.   <<06730>>06350000
                                                               <<06730>>06355000
Returns:  None.  The condition code is not affected.           <<06730>>06360000
                                                               <<06730>>06365000
Special considerations:  DB may be anywhere at entry, same  at <<06730>>06370000
                         exit.                                 <<06730>>06375000
;                                                              <<06730>>06380000
INTEGER                                                        <<06730>>06385000
   DST'AT'ENTRY := -1,                                         <<06730>>06390000
   PCBPT,             << Required by PCB $INCLUDE file.     >> <<06730>>06395000
   SAVE'XDD'SIR,                                               <<06730>>06400000
   XDD'DST,                                                    <<06730>>06405000
   XDD'SIR;                                                    <<06730>>06410000
                                                               <<06730>>06415000
LOGICAL ARRAY                                                  <<06730>>06420000
   XDD(*) = DB + 0;   << Required by XDD $INCLUDE file.     >> <<06730>>06425000
                                                               <<06730>>06430000
LOGICAL POINTER                                                <<06730>>06435000
   PCB = SYSPCBINDEX, << Required by PCB $INCLUDE file.     >> <<06730>>06440000
   XDD'HEAD;          << Required by XDD $INCLUDE file.     >> <<06730>>06445000
                                                               <<06730>>06450000
PCBPT := CURPRC;      << Required by PCB $INCLUDE file.     >> <<06730>>06455000
IF LOGICAL (@XDD'SUBENTRY).(0:1) THEN                          <<06730>>06460000
   BEGIN                                                       <<06730>>06465000
   XDD'DST := ODD'DST;                                         <<06730>>06470000
   XDD'SIR := ODD'SIR;                                         <<06730>>06475000
   END                                                         <<06730>>06480000
ELSE                                                           <<06730>>06485000
   BEGIN                                                       <<06730>>06490000
   XDD'DST := IDD'DST;                                         <<06730>>06495000
   XDD'SIR := IDD'SIR;                                         <<06730>>06500000
   END;                                                        <<06730>>06505000
                                                               <<06730>>06510000
<< Don't need, and can't stand, bit 0 anymore, remove it.   >> <<06730>>06515000
                                                               <<06730>>06520000
@XDD'SUBENTRY := @XDD'SUBENTRY & LSL(1) & LSR(1);              <<06730>>06525000
IF INTEGER (SPCBXDSDST) <> XDD'DST THEN                        <<06730>>06530000
   DST'AT'ENTRY := EXCHANGEDB (XDD'DST);                       <<06730>>06535000
SAVE'XDD'SIR := GETSIR (XDD'SIR);                              <<06730>>06540000
@XDD'HEAD := XDDS'HEAD'INDEX * XDD0'HEAD'LENGTH;               <<06730>>06545000
TOS := @XDDH'FIRST'SUBENTRY;   << Can't fool SPL...         >> <<06730>>06550000
DELINKENTRY (*, XDD'SUBENTRY); <<   any other way.          >> <<06730>>06555000
DEALLOCENTRY (XDD'SUBENTRY);                                   <<06730>>06560000
RELSIR (XDD'SIR, SAVE'XDD'SIR);                                <<06730>>06565000
IF DST'AT'ENTRY <> -1 THEN EXCHANGEDB (DST'AT'ENTRY);          <<06730>>06570000
END;   << of SREMOVEXDD.                                    >> <<06730>>06575000
$PAGE "   ***   SFINDODD/SFINDIDD   ***"                       <<06730>>06580000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>06585000
                                                               <<06730>>06590000
LOGICAL PROCEDURE SFINDODD (DFID, XDD'ADDRESS);                <<06730>>06595000
   VALUE   DFID;                                               <<06730>>06600000
   INTEGER DFID, XDD'ADDRESS;                                  <<06730>>06605000
   OPTION  PRIVILEGED, UNCALLABLE;                             <<06730>>06610000
                                                               <<06730>>06615000
BEGIN                                                          <<06730>>06620000
                                                               <<06730>>06625000
ENTRY SFINDIDD;                                                <<06730>>06630000
                                                               <<06730>>06635000
COMMENT --                                                     <<06730>>06640000
  SFINDxDD searches the xDD linearly for  the  subentry  which <<06730>>06645000
corresponds  to DFID.  It returns the xDD segment-relative ad- <<06730>>06650000
dress in XDD'ADDRESS.(1:15) and "x" (O = 1, I = 0) in (0:1).   <<06730>>06655000
                                                               <<06730>>06660000
Inputs:   DFID.(1:15).  The input of output devicefile ID num- <<06730>>06665000
          ber whose corresponding subentry is to be found.     <<06730>>06670000
                                                               <<06730>>06675000
          DFID.(0:1).  1 if this is an ODD DFID, 0 if  an  IDD <<06730>>06680000
          DFID.  As clear a case of belt and suspenders as can <<06730>>06685000
          be.  We'll use the entry point rather than this bit. <<06730>>06690000
                                                               <<06730>>06695000
Returns:  XDD'ADDRESS.(1:15). The XDD segment-relative address <<06730>>06700000
          of the target subentry, or 0 if  a  subentry  corre- <<06730>>06705000
          sponding to DFID could not be found.                 <<06730>>06710000
                                                               <<06730>>06715000
          XDD'ADDRESS.(0:1).  1 if xDD = ODD and the  subentry <<06730>>06720000
          was  located,  0  if xDD = IDD or the subentry could <<06730>>06725000
          not be found.                                        <<06730>>06730000
                                                               <<06730>>06735000
          Result:  TRUE if the subentry was found, else FALSE. <<06730>>06740000
                                                               <<06730>>06745000
          The condition code is not affected.                  <<06730>>06750000
                                                               <<06730>>06755000
Special considerations: DB must be at the stack on entry, same <<06730>>06760000
                        at exit.  This is because of the stack <<06730>>06765000
                        DB-relative reference  parameter  XDD' <<06730>>06770000
                        ADDRESS.                               <<06730>>06775000
;                                                              <<06730>>06780000
INTEGER                                                        <<06730>>06785000
   MAX'WORD'ADDRESS,   << Last segment-relative address  in >> <<06730>>06790000
                       << currently-allocated  segment that >> <<06730>>06795000
                       << a subentry can start in.          >> <<06730>>06800000
   SAVE'XDD'SIR,                                               <<06730>>06805000
   XDD'DST,                                                    <<06730>>06810000
   XDD'SIR;                                                    <<06730>>06815000
                                                               <<06730>>06820000
LOGICAL                                                        <<06730>>06825000
   FOUND'IT,                                                   <<06730>>06830000
   ODD;                                                        <<06730>>06835000
                                                               <<06730>>06840000
LOGICAL ARRAY                                                  <<06730>>06845000
   XDD(*) = DB + 0;    << Required by XDD $INCLUDE file.    >> <<06730>>06850000
                                                               <<06730>>06855000
LOGICAL POINTER                                                <<06730>>06860000
   XDD'SUBENTRY;       << Required by XDD $INCLUDE file.    >> <<06730>>06865000
                                                               <<06730>>06870000
                                                               <<06730>>06875000
ODD := TRUE;                                                   <<06730>>06880000
                                                               <<06730>>06885000
WHILE FALSE DO                                                 <<06730>>06890000
                                                               <<06730>>06895000
SFINDIDD:                                                      <<06730>>06900000
                                                               <<06730>>06905000
      ODD := FALSE;                                            <<06730>>06910000
                                                               <<06730>>06915000
SFINDODD := FOUND'IT := FALSE;                                 <<06730>>06920000
IF ODD THEN                                                    <<06730>>06925000
   BEGIN                                                       <<06730>>06930000
   XDD'DST := ODD'DST;                                         <<06730>>06935000
   XDD'SIR := ODD'SIR;                                         <<06730>>06940000
   END                                                         <<06730>>06945000
ELSE                                                           <<06730>>06950000
   BEGIN                                                       <<06730>>06955000
   XDD'DST := IDD'DST;                                         <<06730>>06960000
   XDD'SIR := IDD'SIR;                                         <<06730>>06965000
   END;                                                        <<06730>>06970000
                                                               <<06730>>06975000
<< Don't need DFID.(0:1), remove it.                        >> <<06730>>06980000
                                                               <<06730>>06985000
DFID := DFID & LSL(1) & LSR(1);                                <<06730>>06990000
EXCHANGEDB (XDD'DST);                                          <<06730>>06995000
SAVE'XDD'SIR := GETSIR (XDD'SIR);                              <<06730>>07000000
MAX'WORD'ADDRESS := XDD0'CURRENT'SECTORS * WORDS'PER'SECTOR    <<06730>>07005000
                    - XDD0'SUBENTRY'LENGTH;                    <<06730>>07010000
@XDD'SUBENTRY := XDD0'SUBENTRY'AREA;                           <<06730>>07015000
WHILE NOT FOUND'IT AND @XDD'SUBENTRY <= MAX'WORD'ADDRESS DO    <<06730>>07020000
      IF XDD'SUBENTRY <> XDDS'UNUSED'SUBENTRY                  <<06730>>07025000
         AND INTEGER (XDDS'DFID'NUMBER) = DFID THEN            <<06730>>07030000
         FOUND'IT := TRUE                                      <<06730>>07035000
      ELSE @XDD'SUBENTRY := @XDD'SUBENTRY +                    <<06730>>07040000
         INTEGER (XDD0'SUBENTRY'LENGTH);   << Try next.     >> <<06730>>07045000
IF FOUND'IT THEN                                               <<06730>>07050000
   BEGIN   << Must use TOS to avoid split-stack problems.   >> <<06730>>07055000
   TOS := LOGICAL (@XDD'SUBENTRY) LOR (ODD & LSL(15));         <<06730>>07060000
   SFINDODD := TRUE;                                           <<06730>>07065000
   END                                                         <<06730>>07070000
ELSE TOS := 0;                                                 <<06730>>07075000
EXCHANGEDB (STACK);                                            <<06730>>07080000
RELSIR (XDD'SIR, SAVE'XDD'SIR);                                <<06730>>07085000
XDD'ADDRESS := TOS;   << Safe to return this now.           >> <<06730>>07090000
END;   << of SFINDxDD.                                      >> <<06730>>07095000
$PAGE "   ***   SFINDACTIVE   ***"                             <<06730>>07100000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>07105000
                                                               <<06730>>07110000
LOGICAL PROCEDURE SFINDACTIVE (LDEV, DFID);                    <<06730>>07115000
   VALUE   LDEV;                                               <<06730>>07120000
   INTEGER LDEV, DFID;                                         <<06730>>07125000
   OPTION  PRIVILEGED, UNCALLABLE;                             <<06730>>07130000
                                                               <<06730>>07135000
BEGIN COMMENT --                                               <<06730>>07140000
  SFINDACTIVE searches the ODD chain defined by  LDEV  for  an <<06730>>07145000
ACTIVE devicefile ID.  Its number is returned in DFID.         <<06730>>07150000
                                                               <<06730>>07155000
Inputs:   LDEV.  The logical device number of a spooled output <<06730>>07160000
          device.  (If the device is unspooled it is never AC- <<06730>>07165000
          TIVE, and input spooled devices are not considered). <<06730>>07170000
                                                               <<06730>>07175000
Returns:  DFID.(1:15).  The devicefile ID number of  the  cur- <<07330>>07180000
          rently  active  file  on  LDEV,  or 0 if LDEV is not <<07330>>07185000
          spooled for output or if no file is currently ACTIVE <<07330>>07190000
          on it.                                               <<07330>>07195000
                                                               <<07330>>07200000
          DFID.(0:1).  1 if DFID.(1:15) <> 0, else 0.          <<07330>>07205000
                                                               <<06730>>07210000
          SFINDACTIVE.  TRUE if DFID is non-zero, else FALSE.  <<06730>>07215000
                                                               <<06730>>07220000
Special considerations: DB must be at the stack on entry, same <<06730>>07225000
                        at exit.  This is because of the stack <<06730>>07230000
                        DB-relative reference parameter DFID.  <<06730>>07235000
                                                               <<06730>>07240000
                        The LDT and ODD SIR's must be acquired <<06730>>07245000
                        (in that order) before SFINDACTIVE  is <<06730>>07250000
                        called.                                <<06730>>07255000
;                                                              <<06730>>07260000
INTEGER                                                        <<06730>>07265000
   LDT'INDEX := 0;                                             <<06730>>07270000
                                                               <<06730>>07275000
LOGICAL                                                        <<06730>>07280000
   FOUND'IT := FALSE;                                          <<06730>>07285000
                                                               <<06730>>07290000
LOGICAL ARRAY                                                  <<06730>>07295000
   LDT(0:SIZE'OF'LDT'ENTRY-1) = Q,  << to access w/DB @ ODD >> <<07050>>07300000
   XDD(*) = DB + 0;    << Required by XDD $INCLUDE file.    >> <<06730>>07305000
                                                               <<06730>>07310000
LOGICAL POINTER                                                <<06730>>07315000
   XDD'HEAD,           << Required by XDD $INCLUDE file.    >> <<06730>>07320000
   XDD'SUBENTRY;       << This one too.                     >> <<06730>>07325000
                                                               <<06730>>07330000
DEFINE                 << Required by LPDT $INCLUDE file.   >> <<06730>>07335000
   LPDT'INDEX = LDEV * INTEGER (LPDT'ENTRY'SIZE)#;             <<06730>>07340000
                                                               <<06730>>07345000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>07350000
                                                               <<06730>>07355000
                                                               <<06730>>07360000
SFINDACTIVE := FALSE;                                          <<06730>>07365000
DFID := 0;                                                     <<06730>>07370000
IF LDEV <= 0 THEN RETURN;                                      <<06730>>07375000
MOVEFROMDSEG (@LDT, LDT'DST, 0, SIZE'OF'LDT'ENTRY);            <<06730>>07380000
IF LDEV > INTEGER (LDT'NUM'ENTRIES) THEN RETURN;               <<06730>>07385000
IF LPDT'VIRTUAL'DEVICE THEN RETURN;                            <<06730>>07390000
MOVEFROMDSEG (@LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,         <<06730>>07395000
              SIZE'OF'LDT'ENTRY);                              <<06730>>07400000
IF LDT'SPOOL'STATE <> LDT'OUTPUT'SPOOLED THEN RETURN;          <<06730>>07405000
EXCHANGEDB (ODD'DST);                                          <<06730>>07410000
@XDD'HEAD := LDT'XDD'HEAD'INDEX * XDD0'HEAD'LENGTH;            <<06730>>07415000
@XDD'SUBENTRY := XDDH'FIRST'SUBENTRY;                          <<06730>>07420000
WHILE @XDD'SUBENTRY <> XDDS'END'OF'CHAIN AND NOT FOUND'IT DO   <<06730>>07425000
      IF XDD'SUBENTRY <> XDDS'UNUSED'SUBENTRY                  <<06730>>07430000
         AND XDDS'SPOOL'STATE = XDDS'ACTIVE                    <<06730>>07435000
         THEN FOUND'IT := TRUE                                 <<06730>>07440000
      ELSE @XDD'SUBENTRY := XDDS'NEXT'SUBENTRY;                <<06730>>07445000
IF FOUND'IT THEN                                               <<06730>>07450000
   BEGIN   << Must use TOS to avoid split-stack problems.   >> <<06730>>07455000
   SFINDACTIVE := TRUE;                                        <<06730>>07460000
   TOS := XDDS'DFID'NUMBER LOR (XDDS'DFID'IN'OR'OUT & LSL(15));<<06730>>07465000
   END                                                         <<06730>>07470000
ELSE TOS := 0;                                                 <<06730>>07475000
EXCHANGEDB (STACK);                                            <<06730>>07480000
DFID := TOS;   << Safe to return this now.                  >> <<06730>>07485000
END;           << of SFINDACTIVE.                           >> <<06730>>07490000
$PAGE "   ***   XDDSPOOLINFO   ***"                            <<06730>>07495000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>07500000
                                                               <<06730>>07505000
DOUBLE PROCEDURE XDDSPOOLINFO (DVALUE, BITMAP, XDD'SUBENTRY);  <<06730>>07510000
   VALUE   DVALUE, BITMAP, XDD'SUBENTRY;                       <<06730>>07515000
   DOUBLE  DVALUE;                                             <<06730>>07520000
   LOGICAL BITMAP;                                             <<06730>>07525000
   LOGICAL POINTER XDD'SUBENTRY;                               <<06730>>07530000
   OPTION  PRIVILEGED, UNCALLABLE;                             <<06730>>07535000
                                                               <<06730>>07540000
BEGIN COMMENT --                                               <<06730>>07545000
   XDDSPOOLINFO is a hodgepodge of an XDD access  routine.  It <<06730>>07550000
allows  the  caller to get/put/test/modify/increment/decrement <<06730>>07555000
one field in the XDD subentry whose  segment-relative  address <<06730>>07560000
is  passed  in.  (XDD'SUBENTRY bit 0:  TRUE ==> ODD, FALSE ==> <<06730>>07565000
IDD).  The field to be accessed, as well as what is to be done <<06730>>07570000
with it, is determined by the BITMAP parameter (see below  for <<06730>>07575000
details).  New  values  for fields are passed in DVALUE, while <<06730>>07580000
any existing or modified values are returned in the result.    <<06730>>07585000
  Since only one operation per call is allowed, the least sig- <<06730>>07590000
nificant bit in BITMAP (except bit 15, which  is  a  direction <<06730>>07595000
bit) determines which operation is performed.                  <<06730>>07600000
                                                               <<06730>>07605000
BITMAP    BITMAP               FUNCTION                        <<06730>>07610000
 bit      bit 15                                               <<06730>>07615000
-------------------------------------------------------------- <<06730>>07620000
                                                               <<06730>>07625000
  0          X      Not defined.                               <<06730>>07630000
                                                               <<06730>>07635000
  1          X      Not defined.                               <<06730>>07640000
                                                               <<06730>>07645000
  2          X      Not defined.                               <<06730>>07650000
                                                               <<06730>>07655000
  3          1      Set Job Aborted bit.                       <<06730>>07660000
             0      Return state of Job Aborted bit.           <<06730>>07665000
                                                               <<06730>>07670000
  4          X      Return DFID number.                        <<06730>>07675000
                                                               <<06730>>07680000
  5          1      Decrement number of extents by 1.          <<06730>>07685000
             0      Increment number of extents by 1 -AND-     <<06730>>07690000
                      increment number of records by DVALUE.   <<06730>>07695000
                                                               <<06730>>07700000
  6          1      Set Purge Extents (SQEEZE) bit.            <<06730>>07705000
             0      Return state of Purge Extents bit.         <<06730>>07710000
                                                               <<06730>>07715000
  7          X      Return state of Spaced Out bit.            <<06730>>07720000
                                                               <<06730>>07725000
  8          X      Set Spaced Out bit.                        <<06730>>07730000
                                                               <<06730>>07735000
  9          X      Increment number of extents by 1.          <<06730>>07740000
                                                               <<06730>>07745000
 10          1      Set number of extents to DVALUE MSW and    <<06730>>07750000
                      last extent size (sectrs) to DVALUE LSW. <<06730>>07755000
             0      Return the same information in             <<06730>>07760000
                      XDDSPOOLINFO MSW and LSW.                <<06730>>07765000
                                                               <<06730>>07770000
 11          1      Set number of records to DVALUE.           <<06730>>07775000
             0      Return number of records.                  <<06730>>07780000
                                                               <<06730>>07785000
 12          X      Set the spoolfile to the READY state.      <<06730>>07790000
                                                               <<06730>>07795000
 13          X      Decrement the number of copies (restrict   <<06730>>07800000
                      to >= 0) and return the new number.      <<06730>>07805000
                                                               <<06730>>07810000
 14          1      Set spoolfile label address and LDEV.      <<06730>>07815000
             0      Return spoolfile label address and LDEV.   <<06730>>07820000
                                                               <<06730>>07825000
Return:  See above.  The condition code is not affected.       <<06730>>07830000
                                                               <<06730>>07835000
Special considerations:  DB may be anywhere at entry, same  at <<06730>>07840000
                         exit.                                 <<06730>>07845000
;                                                              <<06730>>07850000
INTEGER                                                        <<06730>>07855000
   COUNT,              << For CASE, corresponds to BITMAP   >> <<06730>>07860000
                       <<   function bit.                   >> <<06730>>07865000
   DVALUE0 = DVALUE,                                           <<06730>>07870000
   DVALUE1 = DVALUE + 1,                                       <<06730>>07875000
   DST'AT'ENTRY := -1,                                         <<06730>>07880000
   PCBPT,              << Required by PCB $INCLUDE file.    >> <<06730>>07885000
   SAVE'XDD'SIR,                                               <<06730>>07890000
   XDD'DST,                                                    <<06730>>07895000
   XDD'SIR;                                                    <<06730>>07900000
                                                               <<06730>>07905000
LOGICAL ARRAY                                                  <<06730>>07910000
   XDD(*) = DB + 0;    << Required by XDD $INCLUDE file.    >> <<06730>>07915000
                                                               <<07104>>07920000
BYTE                                                           <<07104>>07925000
   XDDSPOOLINFO'B = XDDSPOOLINFO;                              <<07104>>07930000
                                                               <<06730>>07935000
LOGICAL POINTER                                                <<06730>>07940000
   PCB = SYSPCBINDEX,  << Required by PCB $INCLUDE file.    >> <<06730>>07945000
   XDD'HEAD;           << Required by XDD $INCLUDE file.    >> <<06730>>07950000
                                                               <<06730>>07955000
DOUBLE POINTER                                                 <<06730>>07960000
   XDD'DSUBENTRY = XDD'SUBENTRY;   << For XDD $INCLUDE file >> <<06730>>07965000
                                                               <<06730>>07970000
DEFINE                                                         <<06730>>07975000
   DECREMENT = BITMAP#,   << Different interpretations of   >> <<06730>>07980000
   SETS      = BITMAP#;   <<   BITMAP.(15:1).               >> <<06730>>07985000
                                                               <<06730>>07990000
                                                               <<06730>>07995000
XDDSPOOLINFO := 0D;                                            <<06730>>08000000
PCBPT := CURPRC;       << Required by PCB $INCLUDE file.    >> <<06730>>08005000
IF LOGICAL (@XDD'SUBENTRY).(0:1) THEN                          <<06730>>08010000
   BEGIN                                                       <<06730>>08015000
   XDD'DST := ODD'DST;                                         <<06730>>08020000
   XDD'SIR := ODD'SIR;                                         <<06730>>08025000
   END                                                         <<06730>>08030000
ELSE                                                           <<06730>>08035000
   BEGIN                                                       <<06730>>08040000
   XDD'DST := IDD'DST;                                         <<06730>>08045000
   XDD'SIR := IDD'SIR;                                         <<06730>>08050000
   END;                                                        <<06730>>08055000
                                                               <<06730>>08060000
<< Don't need, and can't stand, bit 0 anymore, remove it.   >> <<06730>>08065000
                                                               <<06730>>08070000
@XDD'SUBENTRY := @XDD'SUBENTRY & LSL(1) & LSR(1);              <<06730>>08075000
IF INTEGER (SPCBXDSDST) <> XDD'DST THEN                        <<06730>>08080000
   DST'AT'ENTRY := EXCHANGEDB (XDD'DST);                       <<06730>>08085000
SAVE'XDD'SIR := GETSIR (XDD'SIR);                              <<06730>>08090000
IF XDD'SUBENTRY <> XDDS'UNUSED'SUBENTRY                        <<06730>>08095000
   AND BITMAP > 1 THEN            << something to do        >> <<06730>>08100000
   BEGIN   << Scan BITMAP, bit 14 to MSB to find our task.  >> <<06730>>08105000
   COUNT := 14;                                                <<06730>>08110000
   TOS := BITMAP;                                              <<06730>>08115000
   WHILE NOT (TOS := TOS & LSR(1)) DO COUNT := COUNT - 1;      <<06730>>08120000
   DEL;                                                        <<06730>>08125000
   CASE * COUNT OF                                             <<06730>>08130000
   BEGIN                                                       <<06730>>08135000
      ;      << Bit 0 -- unused.                            >> <<06730>>08140000
      ;      << Bit 1 -- unused.                            >> <<06730>>08145000
      ;      << Bit 2 -- unused.                            >> <<06730>>08150000
                                                               <<06730>>08155000
<< *-*-* Bit 3 -- Set or return Job Abort bit.        *-*-* >> <<06730>>08160000
                                                               <<06730>>08165000
      IF SETS                                                  <<06730>>08170000
         THEN ODDS'ABORTED'JOB := TRUE                         <<06730>>08175000
         ELSE XDDSPOOLINFO := DOUBLE (ODDS'ABORTED'JOB);       <<06730>>08180000
                                                               <<06730>>08185000
<< *-*-* Bit 4 -- Return DFID.                        *-*-* >> <<06730>>08190000
                                                               <<06730>>08195000
      XDDSPOOLINFO := DOUBLE (XDDS'DFID'NUMBER LOR             <<06730>>08200000
                      (XDDS'DFID'IN'OR'OUT & LSL(15)));        <<06730>>08205000
                                                               <<06730>>08210000
<< *-*-* Bit 5 -- Decrement number of extents by 1 -OR-     >> <<06730>>08215000
<<                increment by 1 and bump number of records >> <<06730>>08220000
<<                by DVALUE.                          *-*-* >> <<06730>>08225000
                                                               <<06730>>08230000
      BEGIN                                                    <<06730>>08235000
      IF DECREMENT THEN                                        <<06730>>08240000
         XDDS'NUMBER'EXTENTS := XDDS'NUMBER'EXTENTS - 1        <<06730>>08245000
      ELSE                                                     <<06730>>08250000
         BEGIN                                                 <<06730>>08255000
         XDDS'NUMBER'EXTENTS := XDDS'NUMBER'EXTENTS + 1;       <<06730>>08260000
         XDDSD'RECORD'COUNT := XDDSD'RECORD'COUNT + DVALUE;    <<06730>>08265000
         END;                                                  <<06730>>08270000
      WRITEDSEG'SERIAL (XDD'DST);  << Post updated segment. >> <<w7889>>08275000
      END;                                                     <<06730>>08280000
                                                               <<06730>>08285000
<< *-*-* Bit 6 -- Set or return Purge Extents bit.    *-*-* >> <<06730>>08290000
                                                               <<06730>>08295000
      IF SETS THEN                                             <<06730>>08300000
         BEGIN                                                 <<06730>>08305000
         ODDS'PURGE'EXTENTS := TRUE;                           <<06730>>08310000
         WRITEDSEG'SERIAL (XDD'DST); <<Post updated segment.>> <<w7889>>08315000
         END                                                   <<06730>>08320000
      ELSE XDDSPOOLINFO := DOUBLE (ODDS'PURGE'EXTENTS);        <<06730>>08325000
                                                               <<06730>>08330000
<< *-*-* Bit 7 -- Return Spaced Out bit.              *-*-* >> <<06730>>08335000
                                                               <<06730>>08340000
      XDDSPOOLINFO := DOUBLE (XDDS'SPACED'OUT);                <<06730>>08345000
                                                               <<06730>>08350000
<< *-*-* Bit 8 -- Set Spaced Out bit.                 *-*-* >> <<06730>>08355000
                                                               <<06730>>08360000
      BEGIN                                                    <<06730>>08365000
      XDDS'SPACED'OUT := TRUE;                                 <<06730>>08370000
      WRITEDSEG'SERIAL (XDD'DST);  << Post updated segment. >> <<w7889>>08375000
      END;                                                     <<06730>>08380000
                                                               <<06730>>08385000
<< *-*-* Bit 9 -- Increment number of extents by 1.   *-*-* >> <<06730>>08390000
                                                               <<06730>>08395000
      BEGIN                                                    <<06730>>08400000
      XDDS'NUMBER'EXTENTS := XDDS'NUMBER'EXTENTS + 1;          <<06730>>08405000
      WRITEDSEG'SERIAL (XDD'DST);  << Post updated segment. >> <<w7889>>08410000
      END;                                                     <<06730>>08415000
                                                               <<06730>>08420000
<< *-*-* Bit 10 -- Set or return number of extents and      >> <<06730>>08425000
<<                 size of last extent.               *-*-* >> <<06730>>08430000
                                                               <<06730>>08435000
      IF SETS THEN                                             <<06730>>08440000
         BEGIN                                                 <<06730>>08445000
         XDDS'NUMBER'EXTENTS := DVALUE0;                       <<06730>>08450000
         XDDS'LAST'EXTENT'SIZE := DVALUE1;                     <<06730>>08455000
         WRITEDSEG'SERIAL (XDD'DST); <<Post updated segment.>> <<w7889>>08460000
         END                                                   <<06730>>08465000
      ELSE                                                     <<06730>>08470000
         BEGIN   << Gather values on TOS, not nice but...   >> <<06730>>08475000
         TOS := XDDS'NUMBER'EXTENTS;                           <<06730>>08480000
         TOS := XDDS'LAST'EXTENT'SIZE;                         <<06730>>08485000
         XDDSPOOLINFO := TOS;                                  <<06730>>08490000
         END;                                                  <<06730>>08495000
                                                               <<06730>>08500000
<< *-*-* Bit 11 -- Set or return number of records.   *-*-* >> <<06730>>08505000
                                                               <<06730>>08510000
      IF SETS THEN                                             <<06730>>08515000
         BEGIN                                                 <<06730>>08520000
         XDDSD'RECORD'COUNT := DVALUE;                         <<06730>>08525000
         WRITEDSEG'SERIAL (XDD'DST); <<Post updated segment.>> <<w7889>>08530000
         END                                                   <<06730>>08535000
      ELSE XDDSPOOLINFO := XDDSD'RECORD'COUNT;                 <<06730>>08540000
                                                               <<06730>>08545000
<< *-*-* Bit 12 -- Set spoolfile state to READY.      *-*-* >> <<06730>>08550000
                                                               <<06730>>08555000
      BEGIN                                                    <<06730>>08560000
      XDDS'SPOOL'STATE := XDDS'READY;                          <<06730>>08565000
      WRITEDSEG'SERIAL (XDD'DST);  << Post updated segment. >> <<w7889>>08570000
      END;                                                     <<06730>>08575000
                                                               <<06730>>08580000
<< *-*-* Bit 13 -- Decrement # copies, limit to 0.          >> <<06730>>08585000
<<                 Return the result.                 *-*-* >> <<06730>>08590000
                                                               <<06730>>08595000
      BEGIN                                                    <<06730>>08600000
      IF ODDS'NUMBER'COPIES > 0 THEN                           <<06730>>08605000
         ODDS'NUMBER'COPIES := ODDS'NUMBER'COPIES - 1;         <<06730>>08610000
      WRITEDSEG'SERIAL (XDD'DST);  << Post updated segment. >> <<w7889>>08615000
      XDDSPOOLINFO := DOUBLE (ODDS'NUMBER'COPIES);             <<06730>>08620000
      END;                                                     <<06730>>08625000
                                                               <<06730>>08630000
<< *-*-* Bit 14 -- Set or return spoolfile label address    >> <<06730>>08635000
<<                 and LDEV.                          *-*-* >> <<06730>>08640000
                                                               <<06730>>08645000
      IF SETS THEN                                             <<06730>>08650000
         BEGIN                                                 <<06730>>08655000
         XDDSD'DISC'LABEL := DVALUE;                           <<06730>>08660000
                                                               <<07050>>08665000
<< Convert LDEV in XDD disc label field to VTAB index.      >> <<07050>>08670000
                                                               <<07050>>08675000
         XDDS'SPOOFLE'VT'INDEX :=                              <<07050>>08680000
              VTABINX (XDDS'SPOOFLE'VT'INDEX, FALSE);          <<07050>>08685000
         WRITEDSEG'SERIAL (XDD'DST); <<Post updated segment.>> <<w7889>>08690000
         END                                                   <<06730>>08695000
      ELSE                                                     <<06730>>08700000
                                                               <<07050>>08705000
<< Convert VTAB index in XDD disc label field to LDEV.      >> <<07050>>08710000
                                                               <<07050>>08715000
         BEGIN                                                 <<07050>>08720000
         XDDSPOOLINFO := XDDSD'DISC'LABEL;                     <<07104>>08725000
         XDDSPOOLINFO'B := LUN (XDDS'SPOOFLE'VT'INDEX, 0);     <<07104>>08730000
         END;                                                  <<07050>>08735000
                                                               <<06730>>08740000
   END;   << of CASE statement.                             >> <<06730>>08745000
                                                               <<06730>>08750000
   END;   << Something to do.                               >> <<06730>>08755000
RELSIR (XDD'SIR, SAVE'XDD'SIR);                                <<06730>>08760000
IF DST'AT'ENTRY <> -1 THEN EXCHANGEDB (DST'AT'ENTRY);          <<06730>>08765000
END;      << of XDDSPOOLINFO.                               >> <<06730>>08770000
$PAGE "   ***   SPOOLEDDEV   ***"                              <<06730>>08775000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>08780000
                                                               <<06730>>08785000
LOGICAL PROCEDURE SPOOLEDDEV (DEVICE);                         <<06730>>08790000
   VALUE DEVICE;                                               <<06730>>08795000
   INTEGER DEVICE;                                             <<06730>>08800000
   OPTION PRIVILEGED, UNCALLABLE;                              <<06730>>08805000
BEGIN COMMENT --                                               <<06730>>08810000
  SPOOLEDDEV examines the LDT and returns spooling information <<06730>>08815000
about DEVICE as follows:                                       <<06730>>08820000
1.  If DEVICE > 0, we assume it's an LDEV.  If the  device  is <<06730>>08825000
    available  to  users as a spooled device (spool queues are <<06730>>08830000
    open), Bit 15 of the result is set. If the device is owned <<06730>>08835000
    by a spooler process, Bit 14 (output spooler) or 13 (input <<06730>>08840000
    spooler) is set.                                           <<06730>>08845000
2.  If DEVICE < 0, we assume it's a Device Class Table  index. <<06730>>08850000
    If  spool queues are open for the class, Bit 15 of the re- <<06730>>08855000
    sult is set.  If not, then every device in  the  class  is <<06730>>08860000
    checked  according  to 1. above.  The resulting Bits 13-15 <<06730>>08865000
    are logically ORed for all devices checked. Callers beware <<06730>>08870000
    the situation where one LDEV has its queues  open  but  is <<06730>>08875000
    not spooled, while for another the reverse is true.        <<06730>>08880000
                                                               <<06730>>08885000
Special considerations:  DB may be anywhere at entry, same  at <<06730>>08890000
                         return.  SPOOLEDDEV is most efficient <<06730>>08895000
                         if called with DB at the stack.       <<06730>>08900000
                                                               <<06730>>08905000
Ways and means:  Starting with MPE V, the Logical Device Table <<06730>>08910000
                 (LDT) and Device Class  Table  (DCT)  are  in <<06730>>08915000
                 different  data segments.  To avoid excessive <<06730>>08920000
                 EXCHANGEDB's, SPOOLEDDEV and other procedures <<06730>>08925000
                 which access both tables make local copies of <<06730>>08930000
                 the entries they work with. Since DCT entries <<06730>>08935000
                 are of variable length, any local  copy  must <<06730>>08940000
                 be built on the stack. References to this ar- <<06730>>08945000
                 ray must be indirect, therefore DB  must  re- <<06730>>08950000
                 main at the stack.                            <<06730>>08955000
;                                                              <<06730>>08960000
INTEGER                                                        <<06730>>08965000
   DEVICES'IN'CLASS,                                           <<06730>>08970000
   DST'AT'ENTRY := -1,                                         <<06730>>08975000
   ENTRY'ADDRESS,                                              <<06730>>08980000
   ENTRY'LENGTH,                                               <<06730>>08985000
   PCBPT,             << Required by PCB $INCLUDE file.     >> <<06730>>08990000
   SAVE'DCT'SIR,                                               <<06730>>08995000
   SAVE'LDT'SIR;                                               <<06730>>09000000
                                                               <<06730>>09005000
LOGICAL ARRAY                                                  <<06730>>09010000
   LDT(0:SIZE'OF'LDT'ENTRY-1) = Q;                             <<07050>>09015000
                                                               <<06730>>09020000
LOGICAL POINTER                                                <<06730>>09025000
   DCT,                                                        <<06730>>09030000
   PCB = SYSPCBINDEX; << Required by PCB $INCLUDE file.     >> <<06730>>09035000
                                                               <<06730>>09040000
DEFINE                                                         <<06730>>09045000
   LDT'INDEX = 0 #;                                            <<06730>>09050000
                                                               <<06730>>09055000
                                                               <<06730>>09060000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>09065000
                                                               <<06730>>09070000
                                                               <<06730>>09075000
SUBROUTINE CHECK'1'DEV (LDEV);                                 <<06730>>09080000
   VALUE LDEV;  INTEGER LDEV;                                  <<06730>>09085000
BEGIN                                                          <<06730>>09090000
MOVEFROMDSEG (@LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,         <<06730>>09095000
              SIZE'OF'LDT'ENTRY);                              <<06730>>09100000
IF LDT'SPOOL'STATE <> LDT'NOT'SPOOLED THEN                     <<06730>>09105000
   IF LDT'SPOOL'STATE = LDT'OUTPUT'SPOOLED                     <<06730>>09110000
      THEN SPOOLEDDEV.(14:1) := TRUE                           <<06730>>09115000
      ELSE SPOOLEDDEV.(13:1) := TRUE;                          <<06730>>09120000
IF LDT'SPOOL'QUEUES = LDT'QOPEN THEN SPOOLEDDEV.(15:1) := TRUE;<<06730>>09125000
END;   << of CHECK'1'DEV.                                   >> <<06730>>09130000
                                                               <<06730>>09135000
<<             Procedure body starts here.                  >> <<06730>>09140000
                                                               <<06730>>09145000
PCBPT := CURPRC;      << Required by PCB $INCLUDE file.     >> <<06730>>09150000
SPOOLEDDEV := 0;                                               <<06730>>09155000
IF DEVICE = 0 THEN RETURN;   << That's a no-no.             >> <<06730>>09160000
IF SPCBXDSDST <> STACK THEN                                    <<06730>>09165000
   DST'AT'ENTRY := EXCHANGEDB (STACK);                         <<06730>>09170000
SAVE'LDT'SIR := GETSIR (LDT'SIR);                              <<06730>>09175000
IF DEVICE > 0 THEN                                             <<06730>>09180000
   CHECK'1'DEV (DEVICE)                                        <<06730>>09185000
ELSE                                                           <<06730>>09190000
   BEGIN   << Device class request, get local copy of entry >> <<06730>>09195000
   SAVE'DCT'SIR := GETSIR (DCT'SIR);                           <<06730>>09200000
   ENTRY'LENGTH := GET'DEVICE'CLASS (-DEVICE, ENTRY'ADDRESS);  <<06730>>09205000
   IF ENTRY'LENGTH <> -1 THEN                                  <<06730>>09210000
      BEGIN   << Valid class index.                         >> <<06730>>09215000
      PUSH (S);                                                <<06730>>09220000
      @DCT := TOS + 1;   << Build DCT entry on stack.       >> <<06730>>09225000
      TOS := ENTRY'LENGTH;                                     <<06730>>09230000
      ASSEMBLE (ADDS 0);                                       <<06730>>09235000
      MOVEFROMDSEG (@DCT, DCT'DST, ENTRY'ADDRESS,              <<06730>>09240000
                    ENTRY'LENGTH);                             <<06730>>09245000
      IF DCT'SPOOL'QUEUES = DCT'OPEN                           <<06730>>09250000
         THEN SPOOLEDDEV.(15:1) := TRUE                        <<06730>>09255000
         ELSE                                                  <<06730>>09260000
            BEGIN   << Class queues shut, test ldevs in cls >> <<06730>>09265000
            DEVICES'IN'CLASS := DCT'NUM'DEVICES;               <<06730>>09270000
            WHILE (DEVICES'IN'CLASS := DEVICES'IN'CLASS - 1)   <<06730>>09275000
                  >= 0 DO                                      <<06730>>09280000
                  CHECK'1'DEV (DCT(DCT'FIRST'LDEV +            <<06730>>09285000
                        DEVICES'IN'CLASS));                    <<06730>>09290000
            END;    << Class queues shut.                      <<06730>>09295000
      END;          << Valid class index.                   >> <<06730>>09300000
   RELSIR (DCT'SIR, SAVE'DCT'SIR);                             <<06730>>09305000
   END;    << Device class request.                         >> <<06730>>09310000
RELSIR (LDT'SIR, SAVE'LDT'SIR);                                <<06730>>09315000
IF DST'AT'ENTRY <> -1 THEN EXCHANGEDB (DST'AT'ENTRY);          <<06730>>09320000
END;   << of SPOOLEDDEV.                                    >> <<06730>>09325000
$PAGE "   ***   ATOB   ***"                                    <<06730>>09330000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>09335000
                                                               <<06730>>09340000
INTEGER PROCEDURE ATOB (NUMBER'STRING, NUMBER'OF'DIGITS);      <<04377>>09345000
   VALUE NUMBER'OF'DIGITS;                                     <<04377>>09350000
   INTEGER NUMBER'OF'DIGITS;                                   <<04377>>09355000
   BYTE ARRAY NUMBER'STRING;                                   <<04377>>09360000
   OPTION INTERNAL, UNCALLABLE;                                <<04377>>09365000
                                                               <<04377>>09370000
BEGIN COMMENT --                                               <<04377>>09375000
  Converts the first NUMBER'OF'DIGITS or  less  ASCII  decimal <<04377>>09380000
digits  in NUMBER'STRING to binary.  NUMBER'STRING may be ter- <<04377>>09385000
minated by any non-numeric character.                          <<04377>>09390000
;                                                              <<04377>>09395000
INTEGER                                                        <<04377>>09400000
   LOOP'COUNTER,                                               <<04377>>09405000
   RESULT,                                                     <<04377>>09410000
   THIS'DIGIT;                                                 <<04377>>09415000
                                                               <<04377>>09420000
RESULT := 0;                                                   <<04377>>09425000
FOR LOOP'COUNTER := 0 STEP 1 UNTIL NUMBER'OF'DIGITS - 1 DO     <<04377>>09430000
   BEGIN                                                       <<04377>>09435000
   THIS'DIGIT := NUMBER'STRING (LOOP'COUNTER) - "0";           <<04377>>09440000
   IF (0 <= THIS'DIGIT <= 9)                                   <<04377>>09445000
      THEN RESULT := RESULT*10 + THIS'DIGIT                    <<04377>>09450000
      ELSE LOOP'COUNTER := NUMBER'OF'DIGITS;   << Stop loop >> <<04377>>09455000
   END;                                                        <<04377>>09460000
ATOB := RESULT;                                                <<04377>>09465000
END;              << of ATOB.                               >> <<04377>>09470000
$PAGE "   ***   GETCLASS   ***"                                <<06730>>09475000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>09480000
                                                               <<06730>>09485000
LOGICAL PROCEDURE GETCLASS (RETURN'BUF, EVERYTHING, CLADR,     <<06730>>09490000
                            CLINDEX, CLNAME);                  <<06730>>09495000
   VALUE   CLADR, CLINDEX, EVERYTHING;                         <<06730>>09500000
   INTEGER CLADR, CLINDEX;                                     <<06730>>09505000
   LOGICAL EVERYTHING;                                         <<06730>>09510000
   INTEGER ARRAY CLNAME, RETURN'BUF;                           <<06730>>09515000
   OPTION PRIVILEGED, UNCALLABLE, VARIABLE;                    <<06730>>09520000
                                                               <<06730>>09525000
BEGIN COMMENT --                                               <<06730>>09530000
  GETCLASS returns information from a Device Class Table (DCT) <<06730>>09535000
entry.  Callers can specify the desired entry by one (and only <<06730>>09540000
one) of three methods:                                         <<06730>>09545000
1.  If CLNAME is used, it contains the ASCII name of  the  de- <<06730>>09550000
    sired  class.  GETCLASS then tries to match this name with <<06730>>09555000
    a class name in the DCT.                                   <<06730>>09560000
2.  If CLINDEX is used, it represents the Nth entry  (starting <<06730>>09565000
    with 1) in the DCT, whatever its name.                     <<06730>>09570000
3.  If CLADR is used, it is the  segment-relative  address  of <<06730>>09575000
    the  desired  entry.  This option is normally used for the <<06730>>09580000
    second call to GETCLASS.                                   <<06730>>09585000
  Two calls are needed because DCT entries have  variable  and <<06730>>09590000
unlimited  lengths,  although the length of a particular entry <<06730>>09595000
can be calculated from information stored in the entry.  Call- <<06730>>09600000
ing routines retrieve this length information (along with  the <<06730>>09605000
segment-relative address of the entry) on the first call using <<06730>>09610000
CLNAME or CLINDEX.  They can then configure  enough  space  to <<06730>>09615000
hold  the rest of the entry and call us again, using the CLADR <<06730>>09620000
returned in RETURN'BUF from the first call (thus allowing  di- <<06730>>09625000
rect access of the entry the second time).                     <<06730>>09630000
  If EVERYTHING is FALSE, GETCLASS returns  only  five  words, <<06730>>09635000
including the entry length information. This is the usual sit- <<06730>>09640000
uation for the first call.  For the second call, EVERYTHING is <<06730>>09645000
TRUE.  The same five words are returned, along with the entire <<06730>>09650000
list of logical devices in the class.                          <<06730>>09655000
  With all that said, callers are warned that GETCLASS returns <<06730>>09660000
information in substantially the same form that it  exists  in <<06730>>09665000
the DCT. Changes to that table will be reflected in the length <<06730>>09670000
requirements and contents of RETURN'BUF. This is a severe flaw <<06730>>09675000
in the design, which should justify a change in the  function- <<06730>>09680000
ality  of  the  routine.  Unfortunately,  the routine has many <<06730>>09685000
callers, some of which are the responsibility not only of oth- <<06730>>09690000
er labs but of other divisions as well.  So we in MPE must  be <<06730>>09695000
content with the above warning.                                <<06730>>09700000
                                                               <<06730>>09705000
  Inputs:   EVERYTHING - FALSE, return five words  in  RETURN' <<06730>>09710000
                         BUF as shown below.                   <<06730>>09715000
                       - TRUE, return same five words plus the <<06730>>09720000
                         rest of the LDEV list for the  class. <<06730>>09725000
$PAGE                                                          <<06730>>09730000
        +-->CLNAME     - The ASCII name of a device  class,  8 <<06730>>09735000
        |                bytes,  left-justified  with trailing <<06730>>09740000
        |                blanks.                               <<06730>>09745000
        |                                                      <<06730>>09750000
One and<    CLINDEX    - The Nth entry (1 is first),  whatever <<06730>>09755000
only one|                its name, in the Device Class Table.  <<06730>>09760000
        |                                                      <<06730>>09765000
        +-->CLADR      - The segment-relative address  of  the <<06730>>09770000
                         desired  DCT  entry.  Note:  CLADR is <<06730>>09775000
                         only checked to be  within  the  DCT. <<06730>>09780000
                         The caller is responsible for setting <<06730>>09785000
                         it to the first word of a DCT entry.  <<06730>>09790000
                                                               <<06730>>09795000
  Returns:  Result     - TRUE, found specified entry, info  in <<06730>>09800000
                         RETURN'BUF is valid.                  <<06730>>09805000
                         FALSE,  could  not  match  CLNAME  or <<06730>>09810000
                         CLINDEX.                              <<06730>>09815000
                                                               <<06730>>09820000
            RETURN'BUF - 0:  Segment-relative address of entry <<06730>>09825000
                             (for CLADR next time).            <<06730>>09830000
                         1:  DCT index of entry (0 if GETCLASS <<06730>>09835000
                             called with CLADR).               <<06730>>09840000
                         2:  Word 4 (5th word) of  DCT  entry. <<06730>>09845000
                             Contains  cyclical pointer, class <<06730>>09850000
                             access type, SQ bit.              <<06730>>09855000
                         3:  Number of LDEV's in class.        <<06730>>09860000
                         4:  First LDEV in class.              <<06730>>09865000
                         >4  Returned only if EVERYTHING TRUE. <<06730>>09870000
                             Remaining LDEV's in class.        <<06730>>09875000
                                                               <<06730>>09880000
  System failures:       360:  CLADR not within DCT limits.    <<06730>>09885000
                         365:  More than one of CLNAME,  CLADR <<06730>>09890000
                               or CLINDEX was specified.       <<06730>>09895000
                         367:  RETURN'BUF  or  EVERYTHING  was <<06730>>09900000
                               not specified.                  <<06730>>09905000
                                                               <<06730>>09910000
  Special considerations:  DCT SIR must be acquired externally.<<07330>>09915000
                             DB must be at the stack, same  at <<06730>>09920000
                           exit.                               <<06730>>09925000
;                                                              <<06730>>09930000
EQUATE                                                         <<06730>>09935000
   CLASS'NAME  = 1,  << Access method (from PARM'MASK bits) >> <<06730>>09940000
   DCT'ADDRESS = 4,                                            <<06730>>09945000
   DCT'INDEX   = 2;                                            <<06730>>09950000
                                                               <<06730>>09955000
INTEGER                                                        <<06730>>09960000
   EXTRA'WORDS'TO'MOVE,   << If EVERYTHING TRUE, number  of >> <<06730>>09965000
                          << words  to  return  in addition >> <<06730>>09970000
                          << to first four.                 >> <<06730>>09975000
   METHOD,                                                     <<06730>>09980000
   PARM'MASK = Q - 4,                                          <<06730>>09985000
   THIS'ENTRY;                                                 <<06730>>09990000
                                                               <<06730>>09995000
LOGICAL POINTER                                                <<06730>>10000000
   DCT,                                                        <<06730>>10005000
   DCT'HEAD := 0;   << Required by DCT $INCLUDE file.       >> <<06730>>10010000
                                                               <<06730>>10015000
LOGICAL ARRAY                                                  <<06730>>10020000
   QCLNAME(0:3) = Q;   << Must be direct to accs in spl-stk >> <<06730>>10025000
                                                               <<06730>>10030000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>10035000
                                                               <<06730>>10040000
GETCLASS := FALSE;                                             <<06730>>10045000
IF PARM'MASK < 25 THEN                                         <<06730>>10050000
   SUDDENDEATH (SD367); << RETURN'BUF or EVERYTHING missing >> <<07050>>10055000
METHOD := PARM'MASK.(13:3);                                    <<06730>>10060000
IF METHOD = CLASS'NAME THEN MOVE QCLNAME := CLNAME, (4);       <<06730>>10065000
EXCHANGEDB (DCT'DST);                                          <<06730>>10070000
IF METHOD = DCT'ADDRESS THEN                                   <<06730>>10075000
   BEGIN   << Probably 2nd call w/ EVERYTHING TRUE.         >> <<06730>>10080000
   IF CLADR < INTEGER (DCTH'DCT'BASE) OR                       <<06730>>10085000
      CLADR >= INTEGER (DCTH'TDT'BASE)                         <<06730>>10090000
      THEN SUDDENDEATH (SD360);   << CLADR not within DCT.  >> <<07050>>10095000
   @DCT := CLADR;                                              <<06730>>10100000
   END                                                         <<06730>>10105000
ELSE                                                           <<06730>>10110000
   BEGIN   << Access by class name or DCT index.            >> <<06730>>10115000
   @DCT := DCTH'DCT'BASE;                                      <<06730>>10120000
   THIS'ENTRY := 0;                                            <<06730>>10125000
   WHILE (THIS'ENTRY := THIS'ENTRY + 1) <=                     <<06730>>10130000
         INTEGER (DCTH'NUM'DCT'ENTRIES) DO                     <<06730>>10135000
      BEGIN   << Search until name or index matches.        >> <<06730>>10140000
      IF METHOD = CLASS'NAME THEN                              <<06730>>10145000
                                                               <<06730>>10150000
<< Caution -- the following comparison, though  cumbersome, >> <<06730>>10155000
<< is the only way to avoid illegal address references while>> <<06730>>10160000
<< in split-stack mode.                                     >> <<06730>>10165000
                                                               <<06730>>10170000
         IF QCLNAME = DCT AND QCLNAME(1) = DCT(1) AND          <<06730>>10175000
            QCLNAME(2) = DCT(2) AND QCLNAME(3) = DCT(3) THEN   <<06730>>10180000
            GO TO FOUND'IT                                     <<06730>>10185000
         ELSE   << No match, try next entry.                >> <<06730>>10190000
      ELSE IF METHOD = DCT'INDEX THEN                          <<06730>>10195000
         IF THIS'ENTRY = CLINDEX THEN                          <<06730>>10200000
            GO TO FOUND'IT                                     <<06730>>10205000
         ELSE   << No match, try next entry.                >> <<06730>>10210000
      ELSE SUDDENDEATH (SD365);   << >1 access specified.   >> <<07050>>10215000
      @DCT := @DCT + INTEGER (DCT'NEXT'ENTRY);                 <<06730>>10220000
      END;      << of WHILE loop.                           >> <<06730>>10225000
   EXCHANGEDB (STACK);   << No name or index match.         >> <<06730>>10230000
   RETURN;                                                     <<06730>>10235000
   END;    << Access by class name or DCT index.            >> <<06730>>10240000
                                                               <<06730>>10245000
FOUND'IT:  << DCT now at desired entry.                     >> <<06730>>10250000
                                                               <<06730>>10255000
EXTRA'WORDS'TO'MOVE := DCT'WORDS'IN'ENTRY - DCT'FIRST'LDEV - 1;<<06730>>10260000
EXCHANGEDB (STACK);                                            <<06730>>10265000
RETURN'BUF := @DCT;   << Note:  DCT segment relative.       >> <<06730>>10270000
IF METHOD = DCT'ADDRESS                                        <<06730>>10275000
   THEN RETURN'BUF(1) := 0                                     <<06730>>10280000
   ELSE RETURN'BUF(1) := THIS'ENTRY;   << DCT index.        >> <<06730>>10285000
MOVEFROMDSEG (@RETURN'BUF(2), DCT'DST, @DCT(4), 3);            <<06730>>10290000
IF EVERYTHING AND EXTRA'WORDS'TO'MOVE > 0 THEN                 <<G7907>>10295000
   MOVEFROMDSEG (@RETURN'BUF(5), DCT'DST, @DCT +               <<06730>>10300000
      DCT'FIRST'LDEV + 1, EXTRA'WORDS'TO'MOVE);                <<06730>>10305000
GETCLASS := TRUE;                                              <<06730>>10310000
END;           << of GETCLASS                               >> <<06730>>10315000
$PAGE "   ***   PUTDEV and GETDEV   ***"                       <<06730>>10320000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>10325000
                                                               <<06730>>10330000
LOGICAL PROCEDURE PUTDEV  << & GETDEV >>  (LDEV, TABLE, BUF);           10335000
   VALUE LDEV, TABLE;                                                   10340000
   INTEGER LDEV;      << LOG. DEVICE NO. >>                             10345000
   INTEGER TABLE;     << DST # OF LPDT (13) OR LDT (14) >>              10350000
   INTEGER ARRAY BUF; << TABLE ENTRY DESTINATION OR SOURCE >>           10355000
   OPTION PRIVILEGED, UNCALLABLE;                                       10360000
                                                                        10365000
BEGIN COMMENT --                                               <<06730>>10370000
  PUTDEV moves entry image in BUF into entry LDEV of table TA- <<06730>>10375000
BLE, where TABLE is either the LDT or LPDT.  The image is  not <<06730>>10380000
checked for correctness, only that an entry for LDEV exists in <<06730>>10385000
TABLE (that is, LDEV does not exceed the maximum for  the  ta- <<06730>>10390000
ble).                                                          <<06730>>10395000
  GETDEV returns entry LDEV of table TABLE (LDT  or  LPDT)  in <<06730>>10400000
BUF.                                                           <<06730>>10405000
                                                               <<06730>>10410000
  The procedure result is returned as follows:                 <<06730>>10415000
      TRUE  - All O.K., BUF returned if GETDEV.                <<06730>>10420000
      FALSE - LDEV < 0 or > max configured -OR- (GETDEV  only) <<06730>>10425000
              LDEV  is unassigned (i.e., table entry is not in <<06730>>10430000
              use, should never occur).                        <<06730>>10435000
                                                               <<06730>>10440000
  Special considerations:                                      <<06730>>10445000
    DB must be at the stack at entry, unchanged at exit.       <<06730>>10450000
    The caller must have acquired the appropriate SIR.         <<06730>>10455000
;                                                              <<06730>>10460000
ENTRY                                                          <<06730>>10465000
   GETDEV;                                                     <<06730>>10470000
                                                               <<06730>>10475000
LOGICAL                                                        <<06730>>10480000
   GET := FALSE;         << GETDEV/PUTDEV flag.             >> <<06730>>10485000
                                                               <<06730>>10490000
INTEGER                                                        <<06730>>10495000
   MAX'ENTRY,                                                  <<06730>>10500000
   TABLE'SIZE;                                                 <<06730>>10505000
                                                               <<06730>>10510000
LOGICAL ARRAY                                                  <<06730>>10515000
   LDT (0:SIZE'OF'LDT'ENTRY - 1);   << For header entry.    >> <<06730>>10520000
                                                               <<06730>>10525000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>10530000
                                                               <<06730>>10535000
SUBROUTINE DEF'MOVETODSEG;                                     <<06730>>10540000
                                                               <<06730>>10545000
<< ****************** Procedure starts here. ************** >> <<06730>>10550000
                                                               <<06730>>10555000
IF FALSE THEN                                                  <<06730>>10560000
                                                               <<06730>>10565000
GETDEV:                                                        <<06730>>10570000
                                                               <<06730>>10575000
   GET := TRUE;                                                <<06730>>10580000
                                                               <<06730>>10585000
PUTDEV := FALSE;                                               <<06730>>10590000
IF LDEV > 0 THEN                                               <<06730>>10595000
   BEGIN   << Passed the first test.                        >> <<06730>>10600000
   IF TABLE = LPDT'DST                                         <<06730>>10605000
      THEN                                                     <<06730>>10610000
         BEGIN                                                 <<06730>>10615000
         TABLE'SIZE := LPDT'ENTRY'SIZE;                        <<06730>>10620000
         MAX'ENTRY  := LPDT'MAX'ENTRIES;                       <<06730>>10625000
         END                                                   <<06730>>10630000
      ELSE                                                     <<06730>>10635000
         BEGIN   << Not LPDT, must be LDT.                  >> <<06730>>10640000
         MOVEFROMDSEG (@LDT, LDT'DST, 0 << base of segment >>, <<06730>>10645000
                       SIZE'OF'LDT'ENTRY);                     <<06730>>10650000
         TABLE'SIZE := LDT'ENTRY'SIZE;                         <<06730>>10655000
         MAX'ENTRY  := LDT'NUM'ENTRIES;                        <<06730>>10660000
         END;                                                  <<06730>>10665000
   IF MAX'ENTRY >= LDEV THEN   << Another test passed.      >> <<06730>>10670000
      IF GET THEN                                              <<06730>>10675000
         BEGIN   << GETDEV, return an entry.                >> <<06730>>10680000
                                                               <<06730>>10685000
  COMMENT -- The strange test below, which determines  whether <<06730>>10690000
GETDEV  returns  TRUE  or FALSE, has been preserved unchanged. <<06730>>10695000
Its origins have been lost.  Anyone knowing what these  checks <<06730>>10700000
are for and why they are made is welcome to clear the air.     <<06730>>10705000
;                                                              <<06730>>10710000
         MOVEFROMDSEG (@BUF, TABLE, LDEV * TABLE'SIZE,         <<06730>>10715000
                       TABLE'SIZE);                            <<06730>>10720000
         IF TABLE = LPDT'DST THEN                              <<06730>>10725000
            PUTDEV := (BUF <> 0) LOR (BUF(2) <> 0)             <<06730>>10730000
         ELSE PUTDEV := (BUF(2) <> 0);                         <<06730>>10735000
         END     << GETDEV, return an entry.                >> <<06730>>10740000
      ELSE                                                     <<06730>>10745000
         BEGIN   << PUTDEV, move entry to table w/o check.  >> <<06730>>10750000
         IF TABLE = LPDT'DST THEN DISABLE;                     <<S7474>>10755000
         MOVETODSEG (TABLE, LDEV * TABLE'SIZE, @BUF,           <<06730>>10760000
                     TABLE'SIZE);                              <<06730>>10765000
         IF TABLE = LPDT'DST THEN ENABLE;                      <<S7474>>10770000
         PUTDEV := TRUE;                                       <<06730>>10775000
         END;    << PUTDEV, move entry to table w/o check.  >> <<06730>>10780000
   END;    << Passed the first test.                        >> <<06730>>10785000
END;       << of PUTDEV/GETDEV                              >> <<06730>>10790000
$PAGE "   ***   GETDEVINFO   ***"                              <<06730>>10795000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>10800000
                                                               <<06730>>10805000
INTEGER PROCEDURE GETDEVINFO (DEVICE, DEVINFO);                <<06730>>10810000
   BYTE ARRAY DEVICE;                                          <<06730>>10815000
   INTEGER ARRAY DEVINFO;                                      <<06730>>10820000
   OPTION PRIVILEGED, UNCALLABLE;                              <<06730>>10825000
                                                               <<06730>>10830000
BEGIN COMMENT --                                               <<06730>>10835000
  GETDEVINFO returns information about DEVICE in DEVINFO.  The <<06730>>10840000
information returned depends on  whether  DEVICE  specifies  a <<06730>>10845000
class,  a  DS node or a specific LDEV, and is described in de- <<06730>>10850000
tail below.  It includes an LDT entry when a class or LDEV  is <<06730>>10855000
specified, and an LPDT image as well for the latter.           <<06730>>10860000
  Because table entries are  returned  directly,  callers  are <<06730>>10865000
warned  that changes to a table structure will be reflected in <<06730>>10870000
the length requirements and contents of DEVINFO. This is a se- <<06730>>10875000
vere flaw in the design, which should justify a change in  the <<06730>>10880000
functionality  of the routine.  Unfortunately, the routine has <<06730>>10885000
many callers, some of which are the responsibility not only of <<06730>>10890000
other labs but of other divisions as well.  So we in MPE  must <<06730>>10895000
be content with the above warning.                             <<06730>>10900000
                                                               <<06730>>10905000
  Input:                                                       <<06730>>10910000
    DEVICE - An ASCII string representing a device class, a DS <<06730>>10915000
             node, or a logical device. Note that LDEV 6 (say) <<06730>>10920000
             must be specified as "6" (ASCII), not 6  (numeri- <<06730>>10925000
             cal  value).  If  a device class is specified, it <<06730>>10930000
             must be eight  bytes,  left-justified  and  blank <<06730>>10935000
             filled.  A  DS  node may be shorter, but MUST end <<06730>>10940000
             with "#" to be handled properly.                  <<06730>>10945000
                                                               <<06730>>10950000
  Returns:                                                     <<06730>>10955000
    GETDEVINFO - -1 - Specified LDEV is a virtual device.      <<06730>>10960000
                  0 - No errors.                               <<06730>>10965000
                  1 - Invalid device class  specification (> 8 <<06730>>10970000
                      characters).                             <<07330>>10975000
                  2 - Unknown device class (couldn't be  found <<06730>>10980000
                      in the Device Class Table (DCT).         <<06730>>10985000
                  3 - Unknown or unconfigured LDEV.            <<06730>>10990000
    DEVINFO:                                                   <<06730>>10995000
      If DEVICE is a class name:                               <<06730>>11000000
         DEVINFO(0)          - DCT index of class (< 0).       <<06730>>11005000
                (1)          - Device type as  it  appears  in <<06730>>11010000
                               the DCT.                        <<06730>>11015000
                (2)          - Word 4 of the DCT  entry  (con- <<06730>>11020000
                               tains  cyclical  ptr, class ac- <<06730>>11025000
                               cess type, SQ bit).             <<06730>>11030000
                (3)          - Not used (contents random).     <<06730>>11035000
                (4) - (10)   - LDT entry of 1st LDEV in class. <<06730>>11040000
                (11) - (12)  - Not used (contents random).     <<06730>>11045000
                                                               <<06730>>11050000
      If DEVICE is a DS node:                                  <<06730>>11055000
         DEVINFO(0), (2)-(12)- 0                               <<06730>>11060000
                (1)          - 41 (DS device type).            <<06730>>11065000
$PAGE                                                          <<06730>>11070000
      If DEVICE is a specific LDEV:                            <<06730>>11075000
         DEVINFO(0)          - Numerical value of LDEV (> 0).  <<06730>>11080000
                (1)          - Device type from Logical Device <<06730>>11085000
                               Table (LDT), except that Serial <<06730>>11090000
                               Disc always returns 31, Foreign <<06730>>11095000
                               Disc always returns 7.          <<06730>>11100000
                (2)-(5)      - LPDT entry of LDEV.             <<06730>>11105000
                (6)-(12)     - LDT entry of LDEV.              <<06730>>11110000
                                                               <<06730>>11115000
  Special considerations:  DB must be at the stack  at  entry, <<06730>>11120000
                           same at return.                     <<06730>>11125000
;                                                              <<06730>>11130000
EQUATE                                                         <<06730>>11135000
   BLANK             = %40,                                    <<06730>>11140000
   CR                = %15,                                    <<06730>>11145000
   DS'DEVICE'TYPE    =  41,                                    <<06730>>11150000
   INVALID'DEV'CLASS =   1,                                    <<06730>>11155000
   NO'ERROR          =   0,                                    <<06730>>11160000
   UNKNOWN'DEV'CLASS =   2,                                    <<06730>>11165000
   UNKNOWN'LDEV      =   3,                                    <<06730>>11170000
   VIRTUAL'DEVICE    =  -1;                                    <<06730>>11175000
                                                               <<06730>>11180000
INTEGER                                                        <<06730>>11185000
   LDT'INDEX     := 0,   << Needed by LDT DEFINEs.          >> <<06730>>11190000
   LDEV              ,                                         <<06730>>11195000
   LPDT'INDEX,           << Needed by LPDT DEFINEs.         >> <<06730>>11200000
   NAME'LENGTH,                                                <<06730>>11205000
   SAVE'LDT'SIR;                                               <<06730>>11210000
                                                               <<06730>>11215000
LOGICAL ARRAY                                                  <<06730>>11220000
   DEV'CLASS'I(0:4),       << Allow extra word for CR.      >> <<06730>>11225000
   GETCLASS'RETN(0:4),     << GETCLASS returns info here.   >> <<06730>>11230000
   LDT(0:SIZE'OF'LDT'ENTRY-1);   << Local LDT entry.        >> <<06730>>11235000
                                                               <<06730>>11240000
BYTE ARRAY                                                     <<06730>>11245000
   DEV'CLASS(*)     = DEV'CLASS'I;                             <<06730>>11250000
$PAGE                                                          <<06730>>11255000
GETDEVINFO := NO'ERROR;                                        <<06730>>11260000
DEV'CLASS := BLANK;                                            <<06730>>11265000
MOVE DEV'CLASS(1) := DEV'CLASS, (9);                           <<06730>>11270000
IF (LDEV := ATOB (DEVICE, 3)) = 0 THEN                         <<06730>>11275000
   BEGIN   << Device class, part 1.                         >> <<06730>>11280000
   MOVE DEV'CLASS := DEVICE WHILE ANS, 1;                      <<06730>>11285000
   IF (NAME'LENGTH := TOS - @DEV'CLASS) > 8 THEN               <<06730>>11290000
      BEGIN                                                    <<06730>>11295000
      GETDEVINFO := INVALID'DEV'CLASS;                         <<06730>>11300000
      RETURN;                                                  <<06730>>11305000
      END;                                                     <<06730>>11310000
   END;    << Device class, part 1.                         >> <<06730>>11315000
SAVE'LDT'SIR := GETSIR (LDT'SIR);                              <<06730>>11320000
IF LDEV = 0 THEN                                               <<06730>>11325000
   BEGIN   << Device class, part 2.                         >> <<06730>>11330000
   IF GETCLASS (GETCLASS'RETN, FALSE, , , DEV'CLASS'I) THEN    <<06730>>11335000
      BEGIN   << Name matched in DCT, get first LDEV.       >> <<06730>>11340000
      LDEV := GETCLASS'RETN(4);                                <<06730>>11345000
      GETDEV (LDEV, LDT'DST, LDT);   << Get its LDT entry.  >> <<06730>>11350000
      RELSIR (LDT'SIR, SAVE'LDT'SIR);                          <<06730>>11355000
      DEVINFO    := -GETCLASS'RETN(1); << DCT index.        >> <<06730>>11360000
      DEVINFO(2) := GETCLASS'RETN(2);  << Word 4, DCT entry >> <<06730>>11365000
      DEVINFO(1) := DEVINFO(2).(10:6); << Class access type >> <<06730>>11370000
      MOVE DEVINFO(4) := LDT, (SIZE'OF'LDT'ENTRY);             <<06730>>11375000
      END     << Name matched in DCT...                     >> <<06730>>11380000
   ELSE                                                        <<06730>>11385000
      BEGIN   << Name not found in DCT, check for DS node.  >> <<06730>>11390000
      RELSIR (LDT'SIR, SAVE'LDT'SIR);                          <<06730>>11395000
      IF DEVICE(NAME'LENGTH) <> "#" THEN                       <<06731>>11400000
         GETDEVINFO := UNKNOWN'DEV'CLASS                       <<06730>>11405000
      ELSE                                                     <<06730>>11410000
         BEGIN   << Found "#", assume DS node.              >> <<06730>>11415000
         DEVINFO := 0;                                         <<06730>>11420000
         MOVE DEVINFO(2) := DEVINFO, (11);                     <<06730>>11425000
         DEVINFO(1) := DS'DEVICE'TYPE;                         <<06730>>11430000
         END;    << Found "#"...                            >> <<06730>>11435000
      END        << Name not found in DCT...                >> <<06730>>11440000
   END           << Device class, part 2.                   >> <<06730>>11445000
ELSE                                                           <<06730>>11450000
   BEGIN         << Specific LDEV.                          >> <<06730>>11455000
   IF NOT GETDEV (LDEV, LDT'DST, LDT) THEN                     <<06730>>11460000
      BEGIN                                                    <<06730>>11465000
      RELSIR (LDT'SIR, SAVE'LDT'SIR);                          <<06730>>11470000
      GETDEVINFO := UNKNOWN'LDEV;                              <<06730>>11475000
      RETURN;                                                  <<06730>>11480000
      END;                                                     <<06730>>11485000
   RELSIR (LDT'SIR, SAVE'LDT'SIR);                             <<06730>>11490000
   LPDT'INDEX := (DEVINFO := LDEV) * INTEGER (LPDT'ENTRY'SIZE);<<06730>>11495000
   DEVINFO(1) := LDT'DEVICE'TYPE;   << May change in a bit. >> <<06730>>11500000
   MOVE DEVINFO(2+LPDT'ENTRY'SIZE) := LDT, (SIZE'OF'LDT'ENTRY);<<06730>>11505000
   DISABLE;                                                    <<06730>>11510000
   GETDEV (LDEV, LPDT'DST, DEVINFO(2));                        <<06730>>11515000
                                                               <<06730>>11520000
<< Note:  A PV disc cannot be  opened  without  a  PV  pack >> <<06730>>11525000
<< mounted on the spindle. Non-system volumes without discs >> <<06730>>11530000
<< spinning are assumed to be serial discs.                 >> <<06730>>11535000
                                                               <<06730>>11540000
   IF LDT'ACCESS'TYPE = LDT'DIRECT'ACCESS  <<From local copy>> <<06730>>11545000
      AND LPDT'NOT'PV'OR'SYS THEN                              <<06730>>11550000
          IF LPDT'SERIAL'OR'FOREIGN = LPDT'SERIAL              <<06730>>11555000
             THEN DEVINFO(1) := LDT'SERIAL'DISC                <<06730>>11560000
             ELSE DEVINFO(1) := LDT'FOREIGN'DISC;              <<06730>>11565000
   IF LPDT'VIRTUAL'DEVICE THEN GETDEVINFO := VIRTUAL'DEVICE;   <<06730>>11570000
   ENABLE;                                                     <<06730>>11575000
   END;   << Specific LDEV.                                 >> <<06730>>11580000
END;      << of GETDEVINFO.                                 >> <<06730>>11585000
$PAGE "   ***   DISKDEALLOC   ***"                             <<06730>>11590000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>11595000
                                                               <<06730>>11600000
INTEGER PROCEDURE DISKDEALLOC(EXTSIZE,LASTEXTSIZE,NUMEXTS,MAP);  <<MV>> 11605000
    VALUE NUMEXTS,EXTSIZE,LASTEXTSIZE;                           <<MV>> 11610000
   INTEGER NUMEXTS;                                                     11615000
   LOGICAL EXTSIZE, LASTEXTSIZE;                                        11620000
   DOUBLE ARRAY MAP;                                             <<MV>> 11625000
   OPTION PRIVILEGED,UNCALLABLE;                                 <<MV>> 11630000
   BEGIN                                                         <<MV>> 11635000
   <<DEALLOCATES DISK DEVICE AND SPACE                >>         <<MV>> 11640000
   <<IF NUMEXTS>0 THEN THE DISK SPACE WILL BE RETURNED>>         <<MV>> 11645000
   <<OTHERWISE THE DEVICES WILL JUST BE DEALLOCATED   >>         <<MV>> 11650000
   <<   NOTE THAT THE USECOUNT IS NOW BUMPED FOR EACH >>         <<MV>> 11655000
   <<   EXTENT.                                                  <<MV>> 11660000
   <<DB MUST BE SET TO STACK                          >>         <<MV>> 11665000
   <<INPUT............................................>>         <<MV>> 11670000
   <<EXTSIZE          SIZE OF EACH EXTENT.                 >>           11675000
   <<LASTEXTSIZE      SIZE OF LAST EXTENT. (ALL OTHERS SAME)>>          11680000
   <<NUMEXTS         THE NUMBER OF EXTENTS IN THE MAP.   >>      <<MV>> 11685000
   <<   NEGATIVE => SIMPLY DEALLOCATE DISC DEVICES.    >>               11690000
   <<   \NUMEXTS\.(8:1) => SPOOLING CALL               >>               11695000
   <<MAP     AN ARRAY OF DISK ADDRESSES.              >>         <<MV>> 11700000
   <<        FORMAT IS : ONE BYE OF LDEV              >>         <<MV>> 11705000
   <<                    THREE BYTES OF DISKADDR.     >>         <<MV>> 11710000
   <<RETURNS..........................................>>         <<MV>> 11715000
   <<       0               OK                        >>         <<MV>> 11720000
                                                               <<03507>>11725000
   <<SPACE OF ALL EXTENTS POSSIBLE IS RETURNED.       >>        <<MV>>  11730000
   BYTE ARRAY BMAP(*)=MAP;                                      <<MV>>  11735000
   LOGICAL LDEV,COUNT;                                           <<MV>> 11740000
   INTEGER INDEX, LDT'INDEX := 0;                              <<06730>>11745000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY-1);                   <<06730>>11750000
   LOGICAL SAVE'LDT'SIR, RETSPACE;                             <<06730>>11755000
   DOUBLE DISKADDR;                                              <<MV>> 11760000
   BYTE BDISKADDR=DISKADDR;                                      <<MV>> 11765000
   LOGICAL DOWN:=FALSE;  <<DID I PUT THE DEV DOWN?>>                    11770000
   LOGICAL FORSPOOLING := FALSE;    <<SPOOLING CALL?>>                  11775000
   DEFINE TYPE'OF'ERROR = [8/7,8/4]#; <<ID=7,4-unexpected er>> <<04811>>11780000
   DEFINE MSG'UNEXPECTED'ERROR = %44#;                         <<04811>>11785000
   DEFINE                                                      <<07050>>11790000
      PUSHNUMSS = TOS := SYSCURSPKSEC1;                        <<07050>>11795000
                  TOS := SYSCURSPKSEC2#,                       <<07050>>11800000
                                                               <<07050>>11805000
      POPNUMSS  = SYSCURSPKSEC2 := TOS;                        <<07050>>11810000
                  SYSCURSPKSEC1 := TOS#;                       <<07050>>11815000
                                                               <<04811>>11820000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>11825000
                                                               <<06730>>11830000
SUBROUTINE DEF'MOVETODSEG;                                     <<06730>>11835000
                                                               <<06730>>11840000
   SUBROUTINE DECRUSECOUNT;                                      <<MV>> 11845000
      BEGIN  <<DECREMENT USECOUNT AND CALL DEALLOCATE>>          <<MV>> 11850000
             <<IF IT GOES TO ZERO.                   >>          <<MV>> 11855000
      SAVE'LDT'SIR := GETSIR (LDT'SIR);                        <<06730>>11860000
      MOVEFROMDSEG (@LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,   <<06730>>11865000
                    SIZE'OF'LDT'ENTRY);                        <<06730>>11870000
      IF LDT'FILE'USE'CNT < COUNT THEN                         <<06730>>11875000
         BEGIN                                                 <<04811>>11880000
         <<It is something wrong with LDT usage count which>>  <<04811>>11885000
         <<represents number of allocated extents of open  >>  <<04811>>11890000
         <<files. We are going to disable allocation and   >>  <<04811>>11895000
         <<deallocation disc space on such device. In case >>  <<04811>>11900000
         <<of private volume switching the drive (off-line/>>  <<04811>>11905000
         <<on-line) will enable disc space allocation.     >>  <<04811>>11910000
         PROCESS'DFS'ERROR(LDEV,MSG'UNEXPECTED'ERROR,          <<04811>>11915000
                           TYPE'OF'ERROR);                     <<04811>>11920000
         SOFT'DEATH (420);                                     <<04811>>11925000
         END                                                   <<04811>>11930000
      ELSE                                                     <<04811>>11935000
      BEGIN  <<O.K.>>                                          <<04811>>11940000
      LDT'FILE'USE'CNT := LDT'FILE'USE'CNT - COUNT;            <<06730>>11945000
      IF LDT'FILE'USE'CNT = 0 AND LDT'DOWN'PENDING THEN        <<06730>>11950000
         BEGIN<<DOWN PENDING SO DOWN IT>>                               11955000
         LDT'DOWN'PENDING := FALSE;   << No longer pending. >> <<06730>>11960000
         LDT'AVAIL'TO'SYS := FALSE;   << It's down.         >> <<06730>>11965000
         DOWN:=TRUE;                                                    11970000
                                                               <<03507>>11975000
         << Deallocate and delete disc free space data >>      <<03507>>11980000
         << segment, ignore errors.                    >>      <<03507>>11985000
                                                               <<03507>>11990000
         Deallocate'Dfs'Data'Seg (ldev);                       <<03507>>11995000
                                                               <<03507>>12000000
         Delete'Dfs'Data'Seg (Ldev);                           <<03507>>12005000
                                                               <<03507>>12010000
         END;   << Down pending, so down it.                >> <<06730>>12015000
      MOVETODSEG (LDT'DST, LDEV * SIZE'OF'LDT'ENTRY, @LDT,     <<06730>>12020000
                  SIZE'OF'LDT'ENTRY);                          <<06730>>12025000
      END;                                                     <<04811>>12030000
      RELSIR (LDT'SIR, SAVE'LDT'SIR);                          <<06730>>12035000
      IF DOWN THEN BEGIN                                                12040000
                   GENMSG(1,250,%10000,LDEV,,,,,0);            <<0U.EB>>12045000
                   DOWN:=FALSE;                                         12050000
                   END;                                                 12055000
      END; <<DECRUSECOUNT>>                                      <<MV>> 12060000
                                                                        12065000
                                                                        12070000
   RETSPACE:=NUMEXTS>0;                                          <<MV>> 12075000
   NUMEXTS:=\NUMEXTS\;                                           <<MV>> 12080000
   IF LOGICAL (NUMEXTS.(8:1)) THEN                                      12085000
      BEGIN    <<SPOOLING CALL: SET TRUE EXTSIZE AND FLAG>>             12090000
      EXTSIZE := SYSSPEXTNTSEC;                                <<07050>>12095000
      FORSPOOLING := TRUE;                                              12100000
      NUMEXTS.(8:1) := 0;                                               12105000
      END;                                                              12110000
   IF LASTEXTSIZE = 0 THEN LASTEXTSIZE := EXTSIZE;                      12115000
   COUNT:=0;                                                     <<MV>> 12120000
   LDEV:=BMAP(0);                                                <<MV>> 12125000
   INDEX:=0;                                                     <<MV>> 12130000
   WHILE INDEX<NUMEXTS DO                                        <<MV>> 12135000
   BEGIN                                                         <<MV>> 12140000
   IF BMAP(INDEX*4)<>0 THEN                                      <<MV>> 12145000
      BEGIN  <<A NON ZERO LDEV IN MAP>>                          <<MV>> 12150000
      IF LDEV=LOGICAL(BMAP(X)) THEN                              <<MV>> 12155000
         COUNT:=COUNT+1 <<NUMBER OF TIMES THIS LDEV>>            <<MV>> 12160000
      ELSE                                                       <<MV>> 12165000
         BEGIN <<NEW LDEV; SO BUMP USECOUNTER BY COUNT>>         <<MV>> 12170000
         DECRUSECOUNT;                                           <<MV>> 12175000
         LDEV:=BMAP(INDEX*4);                                    <<MV>> 12180000
         COUNT:=1;<<NEW LDEV>>                                   <<MV>> 12185000
         END;                                                    <<MV>> 12190000
      IF RETSPACE THEN                                           <<MV>> 12195000
         BEGIN                                                   <<MV>> 12200000
         DISKADDR:=MAP(INDEX);                                   <<MV>> 12205000
         BDISKADDR:=0;                                           <<MV>> 12210000
         Return'Disc'Space (ldev, diskaddr,                    <<03507>>12215000
                            (IF index < numexts-1 THEN         <<03507>>12220000
                            DOUBLE (extsize) ELSE              <<03507>>12225000
                            DOUBLE (lastextsize)));            <<03507>>12230000
                                                               <<03507>>12235000
         << The return of disc space can no longer fail >>     <<03507>>12240000
                                                               <<03507>>12245000
            BEGIN    << ALL OKAY >>                                     12250000
            IF FORSPOOLING THEN                                         12255000
               BEGIN    <<SPOOLING CALL: REDUCE COUNT>>                 12260000
               PDISABLE;                                       <<06730>>12265000
               PUSHNUMSS;    <<SUBTRACT FROM SYSTEM COUNT>>             12270000
               TOS := TOS - (IF INDEX >= NUMEXTS-1 THEN                 12275000
                  DOUBLE(LASTEXTSIZE) ELSE DOUBLE(EXTSIZE));            12280000
               POPNUMSS;                                                12285000
               PENABLE;                                        <<06730>>12290000
               END;                                                     12295000
            END;                                                        12300000
         END;                                                    <<MV>> 12305000
      END;                                                       <<MV>> 12310000
      INDEX:=INDEX+1;                                            <<MV>> 12315000
      END;                                                       <<MV>> 12320000
    IF COUNT <> 0 THEN DECRUSECOUNT;                             <<MV>> 12325000
    END;<<DISKDEALLOC>>                                          <<MV>> 12330000
$PAGE "   ***   DISKALLOC   ***"                               <<06730>>12335000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>12340000
                                                               <<06730>>12345000
INTEGER PROCEDURE DISKALLOC(INDX,NUMEXT,SPACEDATA,PVINFO);     <<RH.PV>>12350000
    VALUE INDX,NUMEXT,PVINFO;                                  <<RH.PV>>12355000
                                                            <<MV>>      12360000
    DOUBLE ARRAY SPACEDATA;                                             12365000
    INTEGER INDX,NUMEXT;                                                12370000
    LOGICAL PVINFO;                                            <<RH.PV>>12375000
    OPTION PRIVILEGED,UNCALLABLE;                                       12380000
         <<ALLOCATES DISK DEVICE AND DISK-SPACE. NO DEVICE ALLOCATION >>12385000
         <<WILL BE MADE IF SUFFICIENT DISK-SPACE CANNOT BE FOUND.     >>12390000
         <<INPUT:.....................................................>>12395000
         <<INDX < 0      - INDEX INTO DEVICE CLASS TABLE.             >>12400000
         <<     > 0      - LOGICAL DEVICE NUMBER.                     >>12405000
         <<     = 0       - SPOOLING CALL.        >>                    12410000
         <<NUMEXT        - # EXTENTS REQUIRED                         >>12415000
         <<   (SEE NOTE BELOW)   >>                                     12420000
         <<SPACEDATA     - SIZE OF EACH EXTENT (IN SECTORS)           >>12425000
         <<                (A SIZE MAY BE ZERO IN WHICH CASE NO SPACE >>12430000
         <<                IS ALLOCATED FOR THAT EXTENT - ZERO SIZES  >>12435000
         <<                DO COUNT AS FAR AS NUMEXT IS CONCERNED.)   >>12440000
         <<PVINFO.(0:1)  - USE MVTAB ENTRY AS DEV CLASS      >><<RH.PV>>12445000
         <<      .(4:4)  - MOUNTED VOLUME TABLE INDEX        >><<RH.PV>>12450000
         <<      .(8:8)  - VOLUME MASK OF ALLOWABLE VOLUMES  >><<RH.PV>>12455000
         <<NOTE..IF NUMEXT < 0 THEN SPACEDATA SHOULD  >>         <<MV>> 12460000
         <<CONTAIN THE LDEV-ADDRESS MAP (LDEV IN FIRST>>         <<MV>> 12465000
         <<BYTE OF THE DOUBLE WORD) AND THE DEVICES WILL>>       <<MV>> 12470000
         <<BE ALLOCATED BUT NO SPACE WILL BE ASSIGNED  >>        <<MV>> 12475000
         <<        DB MUST BE AT STACK.                 >>       <<MV>> 12480000
         <<OUTPUT:....................................................>>12485000
                                                                        12490000
                                                                        12495000
                                                                        12500000
         <<SPACEDATA     - DISK ADDRESS OF EACH REQUESTED EXTENT      >>12505000
         <<              NOTE. UPPER BYTE CONTAINS LDEV>>        <<MV>> 12510000
         <<DISKALLOC = 0 - OK, DEVICE AND SPACE ALLOCATED.            >>12515000
         <<           = 1 - Space not available.      >>       <<03507>>12520000
         <<           = 2 - I/O or other error.       >>       <<03507>>12525000
         <<           = 3 - Free space deallocation   >>       <<03507>>12530000
         <<                 disabled on ldev.         >>       <<03507>>12535000
         <<           = 4 - Device unavailable.       >>       <<06730>>12540000
         <<          = 5 - INVALID INDX                               >>12545000
         <<IN CASE OF ERROR NO SPACE OR DEVICES ALLOCATED.            >>12550000
   BEGIN                                                                12555000
    DOUBLE ARRAY                                               <<06730>>12560000
         ADDR(0:31)=Q                                            <<MV>> 12565000
   ;ARRAY LADDR(*)=ADDR                                          <<MV>> 12570000
   ;BYTE ARRAY BADDR(*)=ADDR                                     <<MV>> 12575000
   ;BYTE ARRAY BSPACEDATA(*)=SPACEDATA                           <<MV>> 12580000
   ;ARRAY MVTABENT(0:MVTABSIZE-1)=Q                            <<RH.PV>>12585000
   ;INTEGER                                                             12590000
         LDEV   <<LOGICAL DEVICE NUMBER>>                               12595000
         ,I,J:=-1 <<CURRENT EXTENT POINTER>>,K,V:=-1           <<RH.PV>>12600000
         ,COUNTER <<FOR USECOUNT>>                               <<MV>> 12605000
        ,NLDEV   <<# OF LOGICAL DEVICES IN DEVICE CLASS>>               12610000
        ,DSTX                                                           12615000
        ,CYCP   <<CYCLICAL POINTER>>                                    12620000
        ,COUNT   <<FOR STEPPING THROUGH DCT>>                           12625000
        ,LDT'INDEX := 0                                        <<06730>>12630000
        ,TEMP'DCT   << Holds local @DCT while at DCT'DST.   >> <<06730>>12635000
        ,TEMP'LDT   << Holds local @LDT while at LDT'DST.   >> <<06730>>12640000
        ,ENTRY'ADDRESS    << of Device Class Table entry.   >> <<06730>>12645000
        ,ENTRY'LENGTH     << of Device Class Table entry.   >> <<06730>>12650000
        ,HVOL                                                  <<RH.PV>>12655000
        ,MVTABX                                                <<RH.PV>>12660000
   ;LOGICAL                                                             12665000
         SAVE'DCT'SIR                                          <<06730>>12670000
        ,SAVE'LDT'SIR                                          <<06730>>12675000
        ,SAVE'MVTAB'SIR                                        <<06730>>12680000
        ,MASK    <<VOLUME TEST MASK>>                          <<RH.PV>>12685000
        ,VMASK   <<ALLOWABLE-VOLUME MASK>>                     <<RH.PV>>12690000
        ,ERROR := FALSE                                        <<06730>>12695000
        ,FORSPOOLING := FALSE;                                 <<06730>>12700000
    LOGICAL ARRAY                                              <<06730>>12705000
       LDT(0:SIZE'OF'LDT'ENTRY-1);                             <<06730>>12710000
                                                               <<06730>>12715000
    LOGICAL POINTER                                            <<06730>>12720000
       DCT,          << Space for array is built on stack.  >> <<06730>>12725000
       DCT'HEAD := 0;   << Required by DCT $INCLUDE file.   >> <<06730>>12730000
                                                               <<06730>>12735000
    DEFINE                                                     <<06730>>12740000
       LPDT'INDEX = LDEV * INTEGER (LPDT'ENTRY'SIZE)#;         <<06730>>12745000
                                                               <<03507>>12750000
   << The following var remembers if we have tried to get >>   <<03507>>12755000
   << space on any device in the class and no space was   >>   <<03507>>12760000
   << available.  This is needed so that we return the    >>   <<03507>>12765000
   << disallocation disabled error only when all discs in >>   <<03507>>12770000
   << the class have had free space disabled.             >>   <<03507>>12775000
                                                               <<03507>>12780000
   LOGICAL OUT'OF'SPACE'ON'ANY'DEV := FALSE;                   <<06730>>12785000
                                                               <<03507>>12790000
   INTEGER return'value = diskalloc                            <<03507>>12795000
   ;DEFINE PVALLOC = PVINFO <> 0#                              <<RH.PV>>12800000
   ;DEFINE PVCLASS = PVINFO.PVCLASSF#                          <<RH.PV>>12805000
   ;                                                                    12810000
   DEFINE                                                      <<07050>>12815000
      PUSHMAXSS = TOS := SYSMXSPSEC1;                          <<07050>>12820000
                  TOS := SYSMXSPSEC2#,                         <<07050>>12825000
                                                               <<07050>>12830000
      PUSHNUMSS = TOS := SYSCURSPKSEC1;                        <<07050>>12835000
                  TOS := SYSCURSPKSEC2#,                       <<07050>>12840000
                                                               <<07050>>12845000
      POPNUMSS  = SYSCURSPKSEC2 := TOS;                        <<07050>>12850000
                  SYSCURSPKSEC1 := TOS#;                       <<07050>>12855000
                                                               <<03507>>12860000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>12865000
                                                               <<06730>>12870000
SUBROUTINE DEF'MOVETODSEG;                                     <<06730>>12875000
                                                               <<03507>>12880000
SUBROUTINE GETDSPACE;                                                   12885000
         <<TRY TO GET ALL REQUESTED EXTENTS ON LDEV                   >>12890000
         <<LDEV MUST BE CORRECTLY SET                                 >>12895000
         <<I WILL BE MOST SIGNIFICANT RESULT FROM "DISKSPACE"         >>12900000
         <<ADDRESSES WILL BE PUT IN ADDR(*)                           >>12905000
         <<ALSO BUMPS USECOUNT FOR EACH EXTENT>>                 <<MV>> 12910000
         <<ON EXIT J POINTS TO LAST ALLOCATED EXTENT>>           <<MV>> 12915000
   BEGIN                                                                12920000
   I := 0;   <<FOR CASE WHERE NUMEXT=0>>                       <<06730>>12925000
   COUNTER := 0;                                                 <<MV>> 12930000
   IF NUMEXT >0 THEN                                             <<MV>> 12935000
      BEGIN <<GET SPACE>>                                        <<MV>> 12940000
   WHILE (J := J+1) < NUMEXT DO IF SPACEDATA(J) > 0D THEN      <<06730>>12945000
      BEGIN                                                             12950000
      i := Get'Disc'Space (ldev, spacedata(j), addr(j));       <<03507>>12955000
      IF I<>0 THEN                                               <<MV>> 12960000
         BEGIN <<ERROR OR NO ROOM>>                              <<MV>> 12965000
                                                               <<03507>>12970000
          << Remember if it was a no space error >>            <<03507>>12975000
                                                               <<03507>>12980000
          IF i = 1 THEN                                        <<03507>>12985000
             out'of'space'on'any'dev := TRUE;                  <<03507>>12990000
                                                               <<03507>>12995000
         GOTO UPUSECOUNT;                                        <<MV>> 13000000
         END;                                                    <<MV>> 13005000
      BADDR(4*J):=LDEV;                                          <<MV>> 13010000
      COUNTER := COUNTER +1;                                            13015000
      END;                                                              13020000
 UPUSECOUNT:         J:=J-1;                                     <<MV>> 13025000
      LDT'FILE'USE'CNT := LDT'FILE'USE'CNT + LOGICAL(COUNTER); <<06730>>13030000
      PUTDEV (LDEV, LDT'DST, LDT);                             <<06730>>13035000
      END                                                        <<MV>> 13040000
   ELSE                                                          <<MV>> 13045000
      BEGIN<<ALLOCATE THE DEVICES>>                              <<MV>> 13050000
      LDEV:=BSPACEDATA(0);                                       <<MV>> 13055000
      COUNTER:=0;                                                <<MV>> 13060000
      K:=0;<<POINTS TO THE LAST EXT ALLOCATED>>                  <<MV>> 13065000
      WHILE (J:=J+1)<-NUMEXT DO                                  <<MV>> 13070000
      IF BSPACEDATA(J*4)<>0 THEN                                 <<MV>> 13075000
         BEGIN                                                   <<MV>> 13080000
         IF LDEV=INTEGER(BSPACEDATA(J*4)) THEN                   <<MV>> 13085000
            COUNTER:=COUNTER+1                                   <<MV>> 13090000
         ELSE                                                    <<MV>> 13095000
            BEGIN<<NEW LDEV - BUMP USECOUNT>>                    <<MV>> 13100000
LASTDEV:    IF NOT GETDEV (LDEV, LDT'DST, LDT)                 <<06730>>13105000
               THEN BEGIN                                        <<MV>> 13110000
                J:=K-1;                                          <<MV>> 13115000
                GOTO BADINDX;                                    <<MV>> 13120000
                END;                                             <<MV>> 13125000
            IF LDT'DOWN'PENDING OR NOT LDT'AVAIL'TO'SYS THEN   <<06730>>13130000
               BEGIN<<DEVICE NOT AVAILABLE>>                     <<MV>> 13135000
               DISKALLOC := 4;                                 <<03507>>13140000
               DISKALLOC.(0:8):=LDEV;                            <<MV>> 13145000
               J:=K-1;<<FIX IT FOR DISKDEALLOC>>            <<MV>>      13150000
               GOTO OUT1;                                        <<MV>> 13155000
               END;                                              <<MV>> 13160000
            LDT'FILE'USE'CNT := LDT'FILE'USE'CNT +             <<06730>>13165000
                LOGICAL (COUNTER);                             <<06730>>13170000
            K:=K+COUNTER;                                        <<MV>> 13175000
            COUNTER:=1;                                          <<MV>> 13180000
            PUTDEV (LDEV, LDT'DST, LDT);                       <<06730>>13185000
            LDEV:=BSPACEDATA(J*4);                               <<MV>> 13190000
            END;                                                 <<MV>> 13195000
         END;                                                    <<MV>> 13200000
      IF J =-NUMEXT THEN                                   <<MV>>       13205000
          GOTO LASTDEV <<THIS WILL BUMP THE USECOUNT>>     <<MV>>       13210000
                       <<AND THEN BUMP J            >>     <<MV>>       13215000
      ELSE J:=-NUMEXT-1; <<JUST IN CASE>>                  <<MV>>       13220000
      END;                                                       <<MV>> 13225000
   END;<<GETDSPACE>>                                             <<MV>> 13230000
                                                                        13235000
SUBROUTINE SPACEMSG (TYPE);                                             13240000
   VALUE   TYPE;                                                        13245000
   INTEGER TYPE;                                                        13250000
   BEGIN   << Shut all device and class spool queues.       >> <<06730>>13255000
   TEMP'LDT := @LDT;   << I don't like this either, but ... >> <<06730>>13260000
   TEMP'DCT := @DCT;                                           <<06730>>13265000
   EXCHANGEDB (LDT'DST);                                       <<06730>>13270000
   @LDT := 0;                                                  <<06730>>13275000
   LDT'INDEX := LDT'ENTRY'SIZE;                                <<06730>>13280000
   DO BEGIN   << Device queues first (not that it matters). >> <<06730>>13285000
      LDT'SPOOL'QUEUES := LDT'QSHUT;                           <<06730>>13290000
      LDT'INDEX := LDT'INDEX + INTEGER (LDT'ENTRY'SIZE);       <<06730>>13295000
      END                                                      <<06730>>13300000
     UNTIL LOGICAL(LDT'INDEX)/LDT'ENTRY'SIZE > LDT'NUM'ENTRIES;<<06730>>13305000
   EXCHANGEDB (DCT'DST);                                       <<06730>>13310000
   @DCT := DCTH'DCT'BASE;   << Now shut class queues.       >> <<06730>>13315000
   DO DCT'SPOOL'QUEUES := DCT'SHUT                             <<06730>>13320000
      UNTIL (@DCT := @DCT + INTEGER (DCT'NEXT'ENTRY)) >=       <<06730>>13325000
      INTEGER (DCTH'TDT'BASE);                                 <<06730>>13330000
   EXCHANGEDB (STACK);                                         <<06730>>13335000
   @LDT := TEMP'LDT;   << Restore local array.              >> <<06730>>13340000
   LDT'INDEX := 0;                                             <<06730>>13345000
   @DCT := TEMP'DCT;                                           <<06730>>13350000
   GENMSG(1,TYPE,,,,,,,0);                                     <<0U.EB>>13355000
   END;                                                                 13360000
                                                                        13365000
   return'value := 1;  << Init to no space >>                  <<03507>>13370000
                                                               <<03507>>13375000
   IF PVALLOC THEN                                             <<RH.PV>>13380000
      BEGIN                                                    <<RH.PV>>13385000
      SAVE'MVTAB'SIR := GETSIR (MVTABSIR);                     <<06730>>13390000
      TOS:=PVINFO;                                             <<RH.PV>>13395000
      VMASK:=S0.VMASKF;                                        <<RH.PV>>13400000
      MVTABX:=TOS.MVTABXF;                                     <<RH.PV>>13405000
      MOVEFROMDSEG (@MVTABENT, MVTABDST, MVTABX * MVTABSIZE,   <<06730>>13410000
                    MVTABSIZE);                                <<06730>>13415000
      HVOL:=MVTABENT(1).(0:4);  <<HIGHEST VOLUME INDEX>>       <<RH.PV>>13420000
      END;                                                     <<06730>>13425000
   SAVE'LDT'SIR := GETSIR (LDT'SIR);                           <<06730>>13430000
   SAVE'DCT'SIR := GETSIR (DCT'SIR);                           <<06730>>13435000
   IF INDX = 0 THEN                                                     13440000
      BEGIN    << SPOOLING CALL: USE SYSGLOB VALUES & CHECK SECT CNT >> 13445000
      IF NUMEXT > 0 THEN                                                13450000
         BEGIN    << ACTUAL SECTOR ALLOCATION >>                        13455000
         PDISABLE;                                             <<06730>>13460000
         PUSHNUMSS;    << CHECK & ADJUST SECT COUNT >>                  13465000
         TOS := TOS + (SYSSPEXTNTSEC ** LOGICAL (NUMEXT));     <<07050>>13470000
         ASSEMBLE (DDUP);                                               13475000
         PUSHMAXSS;                                                     13480000
         ASSEMBLE (DCMP);                                               13485000
         IF > THEN                                                      13490000
            BEGIN                                                       13495000
            PENABLE;                                           <<06730>>13500000
            SPACEMSG(232);                                              13505000
            GOTO out1;                                         <<03507>>13510000
            END;                                                        13515000
         POPNUMSS;                                                      13520000
         PENABLE;                                              <<06730>>13525000
         SPACEDATA := DOUBLE (SYSSPEXTNTSEC);                  <<07050>>13530000
         MOVE SPACEDATA (1) := SPACEDATA, ((NUMEXT-1) &ASL(1));         13535000
         << SPL WANTS WORD COUNT, ABOVE >>                              13540000
         END;                                                           13545000
      INDX := SYSSPOOLDCTINDX;                                 <<07050>>13550000
      FORSPOOLING := TRUE;                                              13555000
      END;                                                              13560000
   LADDR:=0;                                                     <<MV>> 13565000
   IF NUMEXT>0 THEN                                              <<MV>> 13570000
      MOVE LADDR(1):=LADDR,(NUMEXT*2-1)                          <<MV>> 13575000
      ELSE                                                       <<MV>> 13580000
         GOTO NOTSPACE;   <<JUST ALLOC DEVICES>>             <<MV>>     13585000
   IF PVCLASS THEN  <<USE MVTAB ENTRY AS PSEUDO DEV. CLASS>>   <<RH.PV>>13590000
      BEGIN                                                    <<RH.PV>>13595000
      MASK:=0;                                                 <<RH.PV>>13600000
      CYCP:=MVTABENT.CYCPF;                                    <<RH.PV>>13605000
NEXTV:                                                         <<RH.PV>>13610000
      WHILE (MASK LAND VMASK) = 0 DO                           <<RH.PV>>13615000
         BEGIN                                                 <<RH.PV>>13620000
         IF vmask = 0 THEN GO out1;                            <<03507>>13625000
         CYCP:=IF CYCP < HVOL THEN (CYCP+1) ELSE 0;            <<RH.PV>>13630000
         MASK:=1 & LSL(CYCP);                                  <<RH.PV>>13635000
         END;                                                  <<RH.PV>>13640000
      VMASK:=VMASK LAND NOT MASK;  <<RESET BIT JUST TESTED>>   <<RH.PV>>13645000
      LDEV:=MVTABENT((CYCP&LSL(1))+5).(0:8);                   <<RH.PV>>13650000
      GO CONT2;                                                <<RH.PV>>13655000
      END;                                                     <<RH.PV>>13660000
   IF INDX >= 0 THEN GO SPECDEV;                               <<06730>>13665000
                                                               <<06730>>13670000
<< Device class request.                                    >> <<06730>>13675000
                                                               <<06730>>13680000
   INDX := -INDX;                                              <<06730>>13685000
   ENTRY'LENGTH := GET'DEVICE'CLASS (INDX, ENTRY'ADDRESS);     <<06730>>13690000
   IF ENTRY'LENGTH = -1 THEN                                   <<06730>>13695000
      BEGIN   <<INVALID INDX>>                                          13700000
BADINDX:                                                                13705000
      DISKALLOC := 5;                                          <<06730>>13710000
OUT1:                                                                   13715000
      RELSIR (DCT'SIR, SAVE'DCT'SIR);                          <<06730>>13720000
      RELSIR (LDT'SIR, SAVE'LDT'SIR);                          <<06730>>13725000
                                                               <<03507>>13730000
      IF return'value = 3 AND out'of'space'on'any'dev          <<03507>>13735000
         THEN return'value := 1;  << Force "out-of-space" >>   <<03507>>13740000
                                                               <<03507>>13745000
      IF PVALLOC THEN RELSIR (MVTABSIR, SAVE'MVTAB'SIR);       <<06730>>13750000
      IF NUMEXT>0 THEN <<RETURN SPACE>>                          <<MV>> 13755000
         BEGIN                                                          13760000
         DISKDEALLOC (LOGICAL (SPACEDATA), LOGICAL (SPACEDATA (J)),     13765000
            J+1, ADDR);                                                 13770000
         IF FORSPOOLING THEN                                            13775000
            BEGIN    << ERR WHEN SPOOLING CALL: SET CNT BACK >>         13780000
            PDISABLE;                                          <<06730>>13785000
            PUSHNUMSS;                                                  13790000
            TOS := TOS -(LOGICAL (SPACEDATA) ** LOGICAL (J+1));         13795000
            POPNUMSS;                                                   13800000
            PENABLE;                                           <<06730>>13805000
            END;                                                        13810000
         END                                                            13815000
      ELSE  <<KEEP SPACE>>                                       <<MV>> 13820000
         DISKDEALLOC(0,0<<IGNORED>>,-J-1,SPACEDATA);             <<MV>> 13825000
      RETURN;                                                           13830000
      END;                                                              13835000
                                                               <<06730>>13840000
  COMMENT -- We need to scan the list of LDEV's in our DCT en- <<06730>>13845000
try.  Unfortunately, the length of the list is  arbitrary  and <<06730>>13850000
varies  from entry to entry.  Thus to make a local copy of the <<06730>>13855000
entry, we must build space for it on the stack.  (We can't de- <<06730>>13860000
clare an array for it because the length is unknown at entry). <<06730>>13865000
;                                                              <<06730>>13870000
   PUSH (S);                                                   <<06730>>13875000
   @DCT := TOS + 1;                                            <<06730>>13880000
   TOS := ENTRY'LENGTH;                                        <<06730>>13885000
   ASSEMBLE (ADDS 0);   << Hope stack has enough room.      >> <<06730>>13890000
   MOVEFROMDSEG (@DCT, DCT'DST, ENTRY'ADDRESS, ENTRY'LENGTH);  <<06730>>13895000
   CYCP := DCT'CYCLICAL'PTR;                                   <<06730>>13900000
   NLDEV := DCT'NUM'DEVICES;                                   <<06730>>13905000
   COUNT := 0;                                                 <<06730>>13910000
NEXT:                                                                   13915000
   IF (COUNT := COUNT+1) > NLDEV THEN                          <<06730>>13920000
      BEGIN                                                             13925000
      IF FORSPOOLING THEN SPACEMSG(233);                                13930000
      GO OUT1;                                                          13935000
      END;                                                              13940000
   IF (CYCP := CYCP+1) > NLDEV THEN CYCP := 1;                 <<06730>>13945000
   LDEV := DCT(DCT'FIRST'LDEV + CYCP - 1);                     <<06730>>13950000
   IF PVALLOC THEN                                             <<RH.PV>>13955000
      BEGIN                                                    <<RH.PV>>13960000
      V:=-1;                                                   <<RH.PV>>13965000
      WHILE (V:=V+1) <= HVOL DO                                <<RH.PV>>13970000
      IF (MVTABENT((V&LSL(1))+5).(0:8) = LOGICAL(LDEV) LAND    <<06730>>13975000
         (((1 & LSL(V)) LAND VMASK) <> 0)) THEN GO CONT2;      <<RH.PV>>13980000
      GO NEXT;                                                 <<RH.PV>>13985000
      END                                                      <<RH.PV>>13990000
   ELSE                                                        <<RH.PV>>13995000
      IF LPDT'NON'SYS'DOMAIN THEN GO NEXT;                     <<06730>>14000000
CONT2:                                                         <<RH.PV>>14005000
   GETDEV (LDEV, LDT'DST, LDT);   << LDT entry for LDEV.    >> <<06730>>14010000
   IF LDT'DOWN'PENDING OR NOT LDT'AVAIL'TO'SYS THEN            <<06730>>14015000
      BEGIN   <<DEVICE NOT AVAILABLE>>                                  14020000
      IF PVCLASS THEN GO NEXTV ELSE GO NEXT;                   <<RH.PV>>14025000
      END;                                                              14030000
   GETDSPACE;                                                           14035000
   return'value := i;                                          <<03507>>14040000
   IF I=0 THEN GO CONT;                                                 14045000
   IF I <> 2 THEN << Not an I/O error >>                       <<03507>>14050000
      IF PVCLASS THEN GO NEXTV ELSE GO NEXT;  <<NO ROOM>>      <<RH.PV>>14055000
   ERROR := TRUE;                                              <<06730>>14060000
CONT:   <<UPDATE CYCLICAL POINTER>>                                     14065000
   IF PVCLASS THEN  <<UPDATE PV CYCP>>                         <<RH.PV>>14070000
      IF HVOL > 0 THEN                                         <<06730>>14075000
         BEGIN   << More than one possible value for CYCP.  >> <<06730>>14080000
         MVTABENT.CYCPF := CYCP;                               <<06730>>14085000
         MOVETODSEG (MVTABDST, MVTABX*MVTABSIZE, @MVTABENT, 1);<<06730>>14090000
         END                                                   <<06730>>14095000
      ELSE                                                     <<06730>>14100000
   ELSE                                                        <<06730>>14105000
      BEGIN   << System disc class, update its cyclical ptr >> <<06730>>14110000
      DCT'CYCLICAL'PTR := CYCP;                                <<06730>>14115000
      MOVETODSEG (DCT'DST, ENTRY'ADDRESS, @DCT, ENTRY'LENGTH); <<06730>>14120000
      END;                                                     <<RH.PV>>14125000
   IF ERROR THEN GO OUT1;                                               14130000
                                                               <<06730>>14135000
LATCHON:                                                         <<MV>> 14140000
   RELSIR (DCT'SIR, SAVE'DCT'SIR);                             <<06730>>14145000
   RELSIR (LDT'SIR, SAVE'LDT'SIR);                             <<06730>>14150000
   IF PVALLOC THEN RELSIR (MVTABSIR, SAVE'MVTAB'SIR);          <<06730>>14155000
   I := -1;                                                    <<06730>>14160000
   WHILE (I := I+1) < NUMEXT DO SPACEDATA(I) := ADDR(I);       <<06730>>14165000
   DISKALLOC := 0;    <<OKAY RETURN>>                                   14170000
   RETURN;                                                              14175000
                                                               <<06730>>14180000
SPECDEV:   <<SPECIFIC DEVICE>>                                          14185000
                                                               <<06730>>14190000
   LDEV := INDX;                                               <<06730>>14195000
   IF PVALLOC THEN                                             <<RH.PV>>14200000
      BEGIN                                                    <<RH.PV>>14205000
      V:=-1;                                                   <<RH.PV>>14210000
      WHILE (V:=V+1) <= HVOL DO                                <<RH.PV>>14215000
      IF (MVTABENT((V&LSL(1))+5).(0:8) = LOGICAL(LDEV) LAND    <<06730>>14220000
         (((1 & LSL(V)) LAND VMASK) <> 0)) THEN  GO CONT3;     <<RH.PV>>14225000
      GO NOTAVAIL;                                             <<00565>>14230000
      END                                                      <<RH.PV>>14235000
   ELSE                                                        <<RH.PV>>14240000
      IF LPDT'NON'SYS'DOMAIN THEN GO NOTAVAIL;                 <<06730>>14245000
CONT3:                                                         <<RH.PV>>14250000
   IF NOT GETDEV (LDEV, LDT'DST, LDT) THEN                     <<06730>>14255000
      BEGIN   <<INVALID LDEV (INDX)>>                                   14260000
      GO BADINDX;                                                       14265000
      END;                                                              14270000
   IF LDT'DOWN'PENDING OR NOT LDT'AVAIL'TO'SYS THEN            <<06730>>14275000
NOTAVAIL:                                                      <<00565>>14280000
      BEGIN   <<DEVICE NOT AVAILABLE>>                                  14285000
      diskalloc := 4;                                          <<03507>>14290000
      GO OUT1;                                                          14295000
      END;                                                              14300000
NOTSPACE:                                              <<MV>>           14305000
   GETDSPACE;                                                           14310000
   IF I=0 THEN GO LATCHON;                                              14315000
   DISKALLOC := I;                                             <<06730>>14320000
   GO OUT1;                                                             14325000
   END;   <<DISKALLOC>>                                                 14330000
$PAGE "    ***   REMOVE'FROM'XDD   ***"                        <<07104>>14335000
$CONTROL SEGMENT=ALLOCUTIL                                     <<07104>>14340000
PROCEDURE REMOVE'FROM'XDD(XDD'INDEX,CI'SESSION);               <<07104>>14345000
VALUE XDD'INDEX,CI'SESSION;                                    <<07104>>14350000
LOGICAL XDD'INDEX,CI'SESSION;                                  <<07104>>14355000
OPTION PRIVILEGED,UNCALLABLE;                                  <<07104>>14360000
                                                               <<07104>>14365000
!------------------------------------------------------------- <<07104>>14370000
! This  procedure  is  called by TERM'REALLOCATE to remove XDD <<07104>>14375000
! entries  that  contain  the given CI'SESSION number from the <<07104>>14380000
! given  XDD  chain.  It scans the subentry links of the given <<07104>>14385000
! head  chain  and  removes all entries with the given session <<07104>>14390000
! number.  It  is  used  when  a  terminal  is  reallocated to <<07104>>14395000
! another CI's process tree and then reallocated back (see the <<07104>>14400000
! comment in TERM'REALLOCATE).                                 <<07104>>14405000
!------------------------------------------------------------- <<07104>>14410000
                                                               <<07104>>14415000
BEGIN                                                          <<07104>>14420000
LOGICAL ARRAY                                                  <<07104>>14425000
   XDD'HEAD(0:SIZE'OF'XDD'HEAD-1),                             <<07104>>14430000
   XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY);                       <<07104>>14435000
INTEGER POINTER                                                <<07104>>14440000
   LINK;          ! Used in call to SREMOVEXDD.                <<07104>>14445000
INTEGER I;        ! Simply used for index variable.            <<07104>>14450000
LOGICAL                                                        <<07104>>14455000
   LINK'PNTR,     ! Points to XDD subentry.                    <<07104>>14460000
   ODD=I,         ! Used to determine if we are using ODD/IDD. <<07104>>14465000
   XDD'HEAD'PNTR, ! Points to the XDD head entry.              <<07104>>14470000
   SAVE'XDD'SIR,  ! Return parm from GETSIR.                   <<07104>>14475000
   XDD'DST,       ! Either ODD or IDD DST.                     <<07104>>14480000
   XDD'SIR;       !   "     "   "   " SIR.                     <<07104>>14485000
DEFINE                                                         <<07104>>14490000
   SESSION'TYPE  = CI'SESSION.(0:2)#,                          <<07104>>14495000
   SESSION'NUM   = CI'SESSION.(2:14)#;                         <<07104>>14500000
                                                               <<07104>>14505000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07104>>14510000
$PAGE                                                          <<07104>>14515000
XDD'HEAD'PNTR := XDD'INDEX*SIZE'OF'XDD'HEAD;                   <<07104>>14520000
FOR I:=1 UNTIL 2 DO                                            <<07104>>14525000
   BEGIN          ! Once for the ODD and once for the IDD.     <<07104>>14530000
   IF ODD THEN                                                 <<07104>>14535000
      BEGIN                                                    <<07104>>14540000
      XDD'DST := ODD'DST;                                      <<07104>>14545000
      XDD'SIR := ODD'SIR;                                      <<07104>>14550000
      END                                                      <<07104>>14555000
   ELSE                                                        <<07104>>14560000
      BEGIN                                                    <<07104>>14565000
      XDD'DST := IDD'DST;                                      <<07104>>14570000
      XDD'SIR := IDD'SIR;                                      <<07104>>14575000
      END;                                                     <<07104>>14580000
   SAVE'XDD'SIR := GETSIR(XDD'SIR);                            <<07104>>14585000
   MOVEFROMDSEG(@XDD'HEAD,XDD'DST,XDD'HEAD'PNTR,               <<07104>>14590000
                SIZE'OF'XDD'HEAD);                             <<07104>>14595000
   LINK'PNTR := XDDH'FIRST'SUBENTRY;                           <<07104>>14600000
                                                               <<07104>>14605000
   WHILE LINK'PNTR <> XDDS'END'OF'CHAIN DO                     <<07104>>14610000
      BEGIN       ! Delete all entries with given session.     <<07104>>14615000
      MOVEFROMDSEG(@XDD'SUBENTRY,XDD'DST,LINK'PNTR,            <<07104>>14620000
                   SIZE'OF'XDD'SUBENTRY);                      <<07104>>14625000
      IF XDDS'JOB'NUMBER = SESSION'NUM AND                     <<07104>>14630000
         XDDS'JOB'TYPE   = SESSION'TYPE THEN                   <<07104>>14635000
         BEGIN    ! Session matches, delete it.                <<07104>>14640000
         @LINK := LINK'PNTR;                                   <<07104>>14645000
         IF ODD THEN                                           <<07104>>14650000
            @LINK.(0:1) := 1;    ! Signify ODD access.         <<07104>>14655000
         SREMOVEXDD(LINK);                                     <<07104>>14660000
         END;                                                  <<07104>>14665000
      LINK'PNTR := XDDS'NEXT'SUBENTRY;                         <<07104>>14670000
      END;                                                     <<07104>>14675000
   RELSIR(XDD'SIR,SAVE'XDD'SIR);                               <<07104>>14680000
   END;                                                        <<07104>>14685000
END;              ! Procedure REMOVE'FROM'XDD.                 <<07104>>14690000
$PAGE          "***   TERM'REALLOCATE   ***"                   <<07104>>14695000
$CONTROL SEGMENT=ALLOCATE                                      <<07104>>14700000
PROCEDURE TERM'REALLOCATE(TERM'LDEV,NEW'CI'PIN);               <<07104>>14705000
VALUE TERM'LDEV,NEW'CI'PIN;                                    <<07104>>14710000
INTEGER TERM'LDEV,NEW'CI'PIN;                                  <<07104>>14715000
OPTION PRIVILEGED,UNCALLABLE;                                  <<07104>>14720000
                                                               <<07104>>14725000
!------------------------------------------------------------- <<07104>>14730000
!  This  procedure  is used by MM/PM 3000 to reallocate a par- <<07104>>14735000
! ticular  terminal  to  another  CI.  This  is done so that a <<07104>>14740000
! process that is in another CI's process tree (the MM monitor <<07104>>14745000
! process tree) can FOPEN and  access the terminal.  This pro- <<07104>>14750000
! cedure is a bit of a kludge, but it works!  All that is bas- <<07104>>14755000
! ically done is that the CI main PIN of the LDT entry for the <<07104>>14760000
! terminal  is modified to reflect the NEW'CI'PIN, sent by the <<07104>>14765000
! MM process.                                                  <<07104>>14770000
!                                                              <<07104>>14775000
!  When the process in the other process tree FOPEN's the ter- <<07104>>14780000
! minal, FOPEN  will  allow  the terminal to be opened because <<07104>>14785000
! the  CI  main  PIN in the LDT matches the CI main PIN of the <<07104>>14790000
! process.  However,  since  the  session  number found in the <<07104>>14795000
! corresponding XDD entries do not match the session number of <<07104>>14800000
! the  process opening the terminal, another IDD and ODD entry <<07104>>14805000
! is  created  for the LDEV containing the new session number. <<07104>>14810000
! Thus,  when  the  original  process reallocates the terminal <<07104>>14815000
! back, we  must remove the XDD entries that were created when <<07104>>14820000
! the  terminal was reopened.  Thus, if the CI main PIN of the <<07104>>14825000
! process  reallocating  the  terminal is equal to the CI main <<07104>>14830000
! PIN  passed  to  us, then  this is the case and we must call <<07104>>14835000
! REMOVE'FROM'XDD  to remove all XDD entries from the terminal <<07104>>14840000
! with  the  session  number  of the CI process that currently <<07104>>14845000
! owns the LDT.                                                <<07104>>14850000
!------------------------------------------------------------- <<07104>>14855000
                                                               <<07104>>14860000
BEGIN                                                          <<07104>>14865000
LOGICAL ARRAY                                                  <<07104>>14870000
   LDT(0:SIZE'OF'LDT'ENTRY-1),                                 <<07104>>14875000
   QARRAY(*) = Q-0;                                            <<07104>>14880000
LOGICAL POINTER                                                <<07104>>14885000
   PCB = SYSPCBINDEX;      ! PCB sysglobal pointer.            <<07104>>14890000
INTEGER                                                        <<07104>>14895000
   LDT'INDEX := 0,         ! Used for LDT defines.             <<07104>>14900000
   CI'JITDST,              ! Jit DST of the "other" CI.        <<07104>>14905000
   MY'CI'PIN,              ! My CI PIN number, from the JIT.   <<07104>>14910000
   CI'SESSION,             ! The session num of "other CI".    <<07104>>14915000
   OLD'CI'PIN,             ! Current owner in LDT of terminal. <<07104>>14920000
   SAVE'LDT'SIR,           ! Return parm from GETSIR.          <<07104>>14925000
   PCBGLOBLOC,             ! Used for PXGLOBAL defines.        <<07104>>14930000
   PCBPT;                  ! Used for PCB defines.             <<07104>>14935000
EQUATE                                                         <<07104>>14940000
   JIT'CI'MAIN'PIN   = 11, ! Offset in JIT of CI main PIN.     <<07104>>14945000
   JIT'SESSION'NUM   = 7,  ! Offset in JIT of session number.  <<07104>>14950000
   STK'JITDST'OFFSET  =11; ! Offset in other stack of JITDST.  <<07104>>14955000
$PAGE     "***   TERM'REALLOCATE - SUBROUTINES   ***"          <<07104>>14960000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07104>>14965000
                                                               <<07104>>14970000
SUBROUTINE GET'MY'CI'PIN;                                      <<07104>>14975000
                                                               <<07104>>14980000
!------------------------------------------------------------- <<07104>>14985000
! Retrieves the CI PIN from the JIT of the current process.    <<07104>>14990000
!------------------------------------------------------------- <<07104>>14995000
                                                               <<07104>>15000000
BEGIN                                                          <<07104>>15005000
PXGLOBAL;                  ! Set PCBGLOBLOC for defines.       <<07104>>15010000
MOVEFROMDSEG(@MY'CI'PIN,PXG'JITDST,JIT'CI'MAIN'PIN,1);         <<07104>>15015000
END;                                                           <<07104>>15020000
                                                               <<07104>>15025000
                                                               <<07104>>15030000
SUBROUTINE GET'CI'SESSION;                                     <<07104>>15035000
                                                               <<07104>>15040000
!------------------------------------------------------------- <<07104>>15045000
! Finds  the  session  number  from the JIT of the CI based on <<07104>>15050000
! the PIN # found in the LDT.  Gets the stack DST from the PCB <<07104>>15055000
! and gets the JIT DST from the CI's stack PXGLOBAL area.      <<07104>>15060000
!------------------------------------------------------------- <<07104>>15065000
                                                               <<07104>>15070000
BEGIN                                                          <<07104>>15075000
PCBPT := OLD'CI'PIN*PCBSIZE;   ! Set PCB pointer for defines.  <<07104>>15080000
MOVEFROMDSEG(@CI'JITDST,SPCBSTKDST,STK'JITDST'OFFSET,1);       <<07104>>15085000
MOVEFROMDSEG(@CI'SESSION,CI'JITDST,JIT'SESSION'NUM,1);         <<07104>>15090000
END;                                                           <<07104>>15095000
                                                               <<07104>>15100000
$PAGE       "***   TERM'REALLOCATE - OUTER BLOCK   ***"        <<07104>>15105000
SAVE'LDT'SIR := GETSIR(LDT'SIR);  ! Obtain proper SIR.         <<07104>>15110000
GETDEV(TERM'LDEV,LDT'DST,LDT);    ! Copy LDT entry to stack.   <<07104>>15115000
OLD'CI'PIN := LDT'MAIN'PIN;       ! Save current owners PIN.   <<07104>>15120000
LDT'MAIN'PIN := NEW'CI'PIN;       ! Insert new CI PIN in LDT.  <<07104>>15125000
PUTDEV(TERM'LDEV,LDT'DST,LDT);    ! Copy changed LDT back.     <<07104>>15130000
RELSIR(LDT'SIR,SAVE'LDT'SIR);                                  <<07104>>15135000
                                                               <<07104>>15140000
GET'MY'CI'PIN;                    ! Retrieve my CI main PIN.   <<07104>>15145000
IF NEW'CI'PIN = MY'CI'PIN THEN                                 <<07104>>15150000
   BEGIN                          ! Clear XDD entries.         <<07104>>15155000
   GET'CI'SESSION;                ! "Other" CI session number. <<07104>>15160000
   REMOVE'FROM'XDD(LDT'XDD'HEAD'INDEX,CI'SESSION);             <<07104>>15165000
   END;                                                        <<07104>>15170000
END;                                                           <<07104>>15175000
$PAGE          "***   FORMSALIGN   ***"                        <<07104>>15180000
$CONTROL SEGMENT= ALLOCATE                                              15185000
                                                                        15190000
PROCEDURE FORMSALIGN(LDEV);                                             15195000
    VALUE LDEV;                                                         15200000
    INTEGER LDEV;                                                       15205000
    OPTION PRIVILEGED,UNCALLABLE;                                       15210000
   BEGIN                                                                15215000
                                                               <<06064>>15220000
   EQUATE                                                      <<06064>>15225000
      FEATURE'ACCESS   =  9,   << 2608S subtypes.           >> <<06064>>15230000
      TRANSPARENT'MODE = 13;                                   <<06064>>15235000
                                                               <<06064>>15240000
   INTEGER ARRAY                                                        15245000
         IBUF(0:65),                                           <<04620>>15250000
         LDT(0:SIZE'OF'LDT'ENTRY - 1);                         <<06730>>15255000
   BYTE POINTER BBUF;                                                   15260000
   LOGICAL OK;                                                 <<04620>>15265000
   INTEGER                                                     <<04620>>15270000
      RSIZE,          << Record size of the device.         >> <<04620>>15275000
      LDT'INDEX := 0, << For LDT $INCLUDE file.             >> <<06730>>15280000
          I;          << General purpose index.             >> <<04620>>15285000
                                                               <<06730>>15290000
   DEFINE                                                      <<06730>>15295000
      LPDT'INDEX = LDEV * INTEGER(LPDT'ENTRY'SIZE)#;           <<06730>>15300000
                                                               <<04620>>15305000
   GETDEV (LDEV, LDT'DST, LDT);  << Local copy of LDT entry >> <<06730>>15310000
                                                               <<04620>>15315000
   <<*******************************************************>> <<04620>>15320000
   << Do forms alignment only on printers and remote spooled>> <<06064>>15325000
   << terminals (also of type PRINTER).  Omit the forms     >> <<06064>>15330000
   << alignment rack (but keep FORMS ALIGNED OK question)   >> <<06064>>15335000
   << for 2608S, because it has a button for the rack.      >> <<06064>>15340000
   <<*******************************************************>> <<04620>>15345000
                                                               <<04620>>15350000
   IF LDT'DEVICE'TYPE = LDT'PRINTER THEN                       <<06730>>15355000
        BEGIN                                                  <<04620>>15360000
        RSIZE := LDT'RECORD'WIDTH;                             <<06730>>15365000
        @BBUF := (@IBUF &LSL(1)) -1;                           <<04620>>15370000
        MOVE IBUF := "....:....#";                             <<04620>>15375000
        MOVE IBUF (5) := IBUF, (61);                           <<04620>>15380000
        I := 10;                                               <<04620>>15385000
        DO BBUF (I) := (I/10) MOD 10 + "0"                     <<04620>>15390000
        UNTIL (I := I + 10) > 130;                             <<04620>>15395000
        DO                                                     <<04620>>15400000
           BEGIN                                               <<04620>>15405000
           IF LPDT'SUBTYPE <> FEATURE'ACCESS                   <<06730>>15410000
              AND LPDT'SUBTYPE <> TRANSPARENT'MODE THEN        <<06730>>15415000
              ATTACHIO (LDEV, 0, 0, @IBUF, 1, RSIZE, 0, 0, 1); <<06730>>15420000
           GENMSG(1,216,%10000,LDEV,,,,,0,1,@OK);              <<04620>>15425000
           END                                                 <<04620>>15430000
        UNTIL OK;                                              <<04620>>15435000
                                                               <<04620>>15440000
        << Call to HELP for STT entry, never executed       >> <<04620>>15445000
                                                               <<04620>>15450000
        IF FALSE THEN HELP;                                    <<04620>>15455000
        END;                                                   <<04620>>15460000
                                                               <<04620>>15465000
   END;   <<FORMS ALIGN>>                                               15470000
$PAGE "***   ASKOP   ***"                                      <<06730>>15475000
$CONTROL SEGMENT = ALLOCATE                                    <<06730>>15480000
                                                               <<06730>>15485000
LOGICAL PROCEDURE ASKOP(REQDEV,FNAME,OLDFLAG,ALLOCDEV,TYPE,JMPIN,       15490000
    SPOOLERNUM,JOBNUM,FLAGS,PTYPE,STRIN,RESPONSE);             <<SD.00>>15495000
    VALUE REQDEV,OLDFLAG,SPOOLERNUM,JOBNUM,JMPIN,FLAGS,PTYPE;  <<SD.00>>15500000
    INTEGER REQDEV,ALLOCDEV,TYPE,SPOOLERNUM,JOBNUM,JMPIN,FLAGS,<<SD.00>>15505000
            PTYPE;                                             <<SD.00>>15510000
    LOGICAL OLDFLAG;                                                    15515000
    INTEGER ARRAY FNAME;                                                15520000
    BYTE ARRAY STRIN,RESPONSE;                                 <<SD.00>>15525000
    OPTION PRIVILEGED,UNCALLABLE,VARIABLE;                              15530000
         <<REQUESTS DEVICE OR DEVICE IN CLASS. IF CLASS, INSURES THAT >>15535000
         <<DEVICE IS IN CLASS.IF REALEE, THEN CHECKS OWNERSHIP AND    >>15540000
         <<WHETHER OLD-DATA ACCEPTING. OPERATOR IS HARASSED UNTIL     >>15545000
         <<HE/SHE/IT GIVES A VALID RESPONSE.                          >>15550000
         <<INPUT:                                                     >>15555000
         <<      REQDEV             - +LDEV OR -CLASS INDEX           >>15560000
         <<      FNAME              - FILE NAME (8BYTES,1ST BLANK     >>15565000
         <<                                               TERMINATES) >>15570000
         <<      OLDFLAG            - TRUE IF OLD REQUEST             >>15575000
         <<      JMPIN              - JOB MAIN PROCESS#               >>15580000
         <<      PTYPE=0#             NO PARAMETER SOUGHT             >>15585000
         <<           =1            - NUMERIC PARM SOUGHT             >>15590000
         <<           =2            - YES/NO PARM SOUGHT              >>15595000
         <<           =3            - STRING PARM SOUGHT              >>15600000
         <<      STRIN !            - FORMATTED PARAMETER DEFINING    >>15605000
         <<                           OPERATOR RESPONSE DESIRED.      >>15610000
         <<                         I.E. ",WRITE RING? (Y/N)",0       >>15615000
         <<                           BYTE ARRAY DELIMITED BY A ZERO  >>15620000
         <<      SPOOLERNUM*        - SPOOLEE LDEV                    >>15625000
         <<      JOBNUM*            - SPOOFLE'S JOB#                  >>15630000
         <<  * SPOOLER CALLERS ONLY                                   >>15635000
         <<  # ONLY NEEDED IF A PARM AFTER LDEV IS WANTED             >>15640000
         <<  ! ONLY NEEDED IF PTYPE=3                                 >>15645000
         <<OUTPUT:                                                    >>15650000
         <<      ASKOP = TRUE       - NOT REJECTED (SEE TYPE)         >>15655000
         <<            = FALSE      - OP.REJECTED (REPLIED "0"OR"NO)  >>15660000
         <<      ALLOCDEV           - +LDEV# (THE ONE OP.GAVE YOU)    >>15665000
         <<      TYPE = 0           - OLD & DATA ACCEPTING            >>15670000
         <<           = 1           - RE-ALLOCATION                   >>15675000
         <<           = 2           - INITIAL ALLOCATION (RESERVED)   >>15680000
         <<                                     (I.E. SS = 3)  <<06730>>15685000
         <<      RESPONSE           - MINUS ONE (-1) FOR "YES"        >>15690000
         <<                           ZERO (0) FOR "NO"               >>15695000
         <<                           THE NUMBER INPUT BY OP (INTEGER)>>15700000
         <<                           OR                              >>15705000
         <<                           STRING WITH LENGTH IN FIRST WORD>>15710000
         <<                           AND CHARACTERS BEGINNING IN     >>15715000
         <<                           SECOND.  MAXLEN=20CHAR          >>15720000
         <<     NOTE: DB AT STACK COMING IN & GOING OUT.              >>15725000
   BEGIN                                                                15730000
   EQUATE                                                               15735000
         OKAY = OPASSIGNED,                                             15740000
         REJECTED = 3,                                                  15745000
         INVALID = 4;                                                   15750000
    DEFINE ACCESS  = FLAGS.(14:2)#;                            <<TL.02>>15755000
    DEFINE LABELED = FLAGS.(7:1)#;                             <<TL.02>>15760000
   DEFINE      <<OPTIONAL PARAMETER BITMAP>>                   <<SD.00>>15765000
         SPOOLERBITS=(10:2)#,                                  <<SD.00>>15770000
         RESPONSEBIT=(15:1)#,                                  <<SD.00>>15775000
         STRINBIT=(14:1)#,                                     <<SD.00>>15780000
         PTYPEBIT=(13:1)#;                                     <<SD.00>>15785000
   LOGICAL                                                              15790000
         CLASSREQ,   <<CLASS REQUEST>>                                  15795000
         SPOOLDEV,   <<CALL FROM SPOOLER>>                              15800000
      AUTOALLOC,  <<AUTOMATICALLY ALLOCATED MAG TAPE>>         <<TL.03>>15805000
      CHECK'FOR'AVR,  <<Check for AVR on tape and sdisc>>      <<03681>>15810000
         SAVE'LDT'SIR,                                         <<06730>>15815000
         SAVE'LPDT'SIR;                                        <<06730>>15820000
   DOUBLE DSTAT'RET;                                           <<03698>>15825000
   INTEGER STAT'RET0=DSTAT'RET;                                <<03698>>15830000
   INTEGER STAT'RET1=STAT'RET0+1;                              <<03698>>15835000
   DEFINE ON'LINE=(STAT'RET1.(14:1)=0)#;                       <<03698>>15840000
   INTEGER                                                              15845000
         I,                                                    <<06730>>15850000
         Q4 = Q-4,   <<BIT MAP>>                                        15855000
         ANSWER,   <<OP.RESPONSE>>                                      15860000
      CLASSLEN,                                                <<00552>>15865000
         RESP,   <<TEMP.STORAGE OF TYPE>>                               15870000
         DEVTOCONSIDER,   <<DEVICE CURRENTLY BEING CONSIDERED>>         15875000
      LDEVN,                                                   <<TL.02>>15880000
         LDT'INDEX := 0,  << These two cells keep the LDT & >> <<06730>>15885000
         LPDT'INDEX,      << LPDT $INCLUDE files happy.     >> <<06730>>15890000
         ENTRY'ADDRESS,   << DCT-rel addr of desired entry. >> <<06730>>15895000
         ENTRY'LENGTH;    << Length of local DCT entry.     >> <<06730>>15900000
   LOGICAL                                                     <<01647>>15905000
      ASSOC'SIR;                   << SAVE SIR FOR ASSOC.   >> <<01647>>15910000
                                                               <<01647>>15915000
   INTEGER ARRAY                                                        15920000
         LFNAME(0:4),   <<LOCAL VERSION OF FNAME(*)>>                   15925000
         LCLASSNAME(0:4),                                               15930000
         JOBNUMBER (0:3),                                               15935000
         ASSOC(0:ASS'ENTRYSIZE);   << Extra word is for     >> <<06730>>15940000
                                   <<   GENMSG terminator.  >> <<06730>>15945000
   BYTE ARRAY                                                           15950000
      ASSOC'(*)=ASSOC,                                         <<00552>>15955000
         BLFNAME(*) = LFNAME,                                           15960000
         BLCLASSNAME(*) = LCLASSNAME,                                   15965000
         BJOBNUMBER (*) = JOBNUMBER;                                    15970000
   LOGICAL ARRAY                                               <<06730>>15975000
         LDT(0:SIZE'OF'LDT'ENTRY - 1);                         <<06730>>15980000
   LOGICAL POINTER                                             <<06730>>15985000
         DCT;             << For Device Class Table entry.  >> <<06730>>15990000
   INTEGER POINTER                                             <<SD.00>>15995000
         TBUF, <<WILL POINT TO OPERATOR REPLY>>                <<SD.00>>16000000
         IOUTBUF; <<WILL POINT TO RESPONSE BUFFER>>            <<SD.00>>16005000
   BYTE ARRAY                                                  <<SD.00>>16010000
         BTBUF(0:26), <<MAX OP REPLY LENGTH IS 27 CHAR>>       <<SD.00>>16015000
         BLANKBUF(0:1); <<DEFAULT INPUT STRING>>               <<SD.00>>16020000
   BYTE POINTER                                                <<SD.00>>16025000
         INBUF:=@BLANKBUF,  <<INPUT STRING HOLDER>>            <<SD.00>>16030000
         OUTBUF:=@BTBUF; <<OUTPUT STRING HOLDER>>              <<SD.00>>16035000
                                                               <<06730>>16040000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>16045000
$PAGE                                                          <<00552>>16050000
SUBROUTINE PARSEPARM;                                          <<SD.00>>16055000
COMMENT: PARSE OPERATOR RESPONSE.  MUST BE IN THE FORM         <<SD.00>>16060000
         LDEV# (OR) YES/NO   ,   PARAMETER                     <<SD.00>>16065000
         PARAMETER MAY BE 1)A NUMBER<=32759                    <<SD.00>>16070000
                          2)"YES" OR "NO"                      <<SD.00>>16075000
                          3)A STRING OF UP TO 20 CHARACTERS    <<SD.00>>16080000
         PARAMETER IS OPTIONAL WITH DEFAULTS BEING             <<SD.00>>16085000
                          1)ZERO                               <<SD.00>>16090000
                          2)"NO"                               <<SD.00>>16095000
                          3)ZERO LENGTH STRING                 <<SD.00>>16100000
         ANY DEVIATION WILL RESULT IN THE OPERATOR BEING       <<SD.00>>16105000
         REASKED.  ((RESP:=INVALID))                           <<SD.00>>16110000
END OF COMMENT;                                                <<SD.00>>16115000
BEGIN <<PARSEPARM>>                                            <<SD.00>>16120000
I:=TBUF; <<LENGTH OF RESPONSE>>                                <<SD.00>>16125000
RESP:=OKAY;                                                    <<SD.00>>16130000
BTBUF(I+2):=%54; <<APPEND COMMA TO INSURE END OF SCAN>>        <<SD.00>>16135000
IF CLASSREQ THEN                                               <<SD.00>>16140000
   BEGIN <<NUMERIC RESPONSE REQUESTED>>                        <<SD.00>>16145000
   I:=1; <<RESPONSE BEGINS IN SECOND WORD>>                    <<SD.00>>16150000
   WHILE BTBUF(I:=I+1)<>%54 <<COMMA>> DO                       <<SD.00>>16155000
     IF %60<=INTEGER(BTBUF(I))<=%71 THEN ELSE RESP:=INVALID;   <<SD.00>>16160000
   END   <<NUMERIC RESPONSE REQUESTED>>                        <<SD.00>>16165000
ELSE                                                           <<SD.00>>16170000
   BEGIN <<YES/NO RESPONSE REQUESTED>>                         <<SD.00>>16175000
   RESP:=INVALID;                                              <<SD.00>>16180000
   IF BTBUF(2)="Y," OR BTBUF(2)="YES," THEN RESP:=OKAY;        <<SD.00>>16185000
   IF BTBUF(2)="N," OR BTBUF(2)="NO,"  OR                      <<04538>>16190000
      BTBUF(2)="0," THEN RESP := OKAY;                         <<04538>>16195000
   END;  <<YES/NO RESPONSE REQUESTED>>                         <<SD.00>>16200000
IF RESP=OKAY THEN                                              <<SD.00>>16205000
   BEGIN <<OPERATOR RESPONSE HAS VALID SYNTAX>>                <<SD.00>>16210000
   IF CLASSREQ THEN                                            <<SD.00>>16215000
      BEGIN <<CONVERT # TO BINARY>>                            <<SD.00>>16220000
      I:=1; <<# BEGINS IN SECOND WORD>>                        <<SD.00>>16225000
      ANSWER:=0; <<ACCUMULATOR>>                               <<SD.00>>16230000
      WHILE BTBUF(I:=I+1)<>%54 AND ANSWER<3276 DO              <<SD.00>>16235000
         ANSWER:=ANSWER*10+INTEGER(BTBUF(I))-%60;              <<SD.00>>16240000
      END   <<CONVERT # TO BINARY>>                            <<SD.00>>16245000
   ELSE                                                        <<SD.00>>16250000
      BEGIN <<SET YES/NO>>                                     <<SD.00>>16255000
      ANSWER:=IF BTBUF(2)="Y" THEN -1<<TRUE>> ELSE 0<<FALSE>>; <<SD.00>>16260000
      I:=2; <<FOR SCAN TO FIND COMMA>>                         <<SD.00>>16265000
      END;  <<SET YES/NO>>                                     <<SD.00>>16270000
   WHILE BTBUF(I)<>%54 DO I:=I+1; <<FIND FIRST COMMA>>         <<SD.00>>16275000
   IF I-1<TBUF THEN                                            <<SD.00>>16280000
      BEGIN <<PARAMETER ENTERED BY OPERATOR>>                  <<SD.00>>16285000
      CASE PTYPE OF                                            <<SD.00>>16290000
         BEGIN <<CASE STATEMENT>>                              <<SD.00>>16295000
            IOUTBUF:=0; <<NO PARAMETER SOUGHT>>                <<SD.00>>16300000
            BEGIN <<NUMERIC PARM SOUGHT>>                      <<SD.00>>16305000
            IOUTBUF:=0; <<ACCUMULATOR>>                        <<SD.00>>16310000
            WHILE BTBUF(I:=I+1)<>%54 DO                        <<SD.00>>16315000
               BEGIN <<CONVERT # TO BINARY>>                   <<SD.00>>16320000
               IF BTBUF(I)<%60 OR BTBUF(I)>%71 THEN RESP:=INVALID;      16325000
               IF IOUTBUF<3276 THEN                            <<SD.00>>16330000
                  IOUTBUF:=IOUTBUF*10+INTEGER(BTBUF(I))-%60    <<SD.00>>16335000
               ELSE                                            <<SD.00>>16340000
                  RESP:=INVALID;                               <<SD.00>>16345000
               END;  <<CONVERT # TO BINARY>>                   <<SD.00>>16350000
            END;  <<NUMERIC PARM SOUGHT>>                      <<SD.00>>16355000
            BEGIN <<YES/NO>>                                   <<SD.00>>16360000
            IF RESP=OKAY THEN                                  <<SD.00>>16365000
               BEGIN <<SET RETURN VALUE FOR YES/NO>>           <<SD.00>>16370000
               RESP:=INVALID;                                  <<SD.00>>16375000
               IF BTBUF(I+1)="Y," OR BTBUF(I+1)="YES," THEN    <<SD.00>>16380000
                  BEGIN <<VALID YES PARM>>                     <<SD.00>>16385000
                  RESP:=OKAY;                                  <<SD.00>>16390000
                  IOUTBUF:=-1; <<TRUE>>                        <<SD.00>>16395000
                  END;  <<VALID YES PARM>>                     <<SD.00>>16400000
               IF BTBUF(I+1)="N," OR BTBUF(I+1)="NO," THEN     <<SD.00>>16405000
                  BEGIN <<VALID NO PARM>>                      <<SD.00>>16410000
                  RESP:=OKAY;                                  <<SD.00>>16415000
                  IOUTBUF:=0; <<FALSE>>                        <<SD.00>>16420000
                  END;  <<VALID NO PARM>>                      <<SD.00>>16425000
               END;  <<SET RETURN VALUE FOR YES/NO>>           <<SD.00>>16430000
            END;  <<YES/NO>>                                   <<SD.00>>16435000
            BEGIN <<STRING RESPONSE SOUGHT>>                   <<SD.00>>16440000
            IOUTBUF:=TBUF-I+1; <<LENGTH OF STRING>>            <<SD.00>>16445000
            MOVE OUTBUF(2):=BTBUF(I+1),(TBUF-I+1);             <<SD.00>>16450000
            END;  <<STRING PARM SOUGHT>>                       <<SD.00>>16455000
         END;  <<CASE STATEMENT>>                              <<SD.00>>16460000
      END   <<PARAMETER ENTERED BY OPERATOR>>                  <<SD.00>>16465000
   ELSE                                                        <<SD.00>>16470000
      BEGIN <<NO PARM ENTERED BY OP>>                          <<SD.00>>16475000
      IF PTYPE>0 THEN IOUTBUF:=0; <<DEFAULTS ARE:>>            <<SD.00>>16480000
                                  <<NUMERIC- 0   >>            <<SD.00>>16485000
                                  <<YES/NO-  NO  >>            <<SD.00>>16490000
                                  <<STRING-  NONE>>            <<SD.00>>16495000
      END;  <<NO PARM ENTERED BY OP>>                          <<SD.00>>16500000
   END;  <<OPERATOR RESPONSE HAS VALID SYNTAX>>                <<SD.00>>16505000
END;  <<PARSEPARM>>                                            <<SD.00>>16510000
$PAGE                                                          <<00552>>16515000
LOGICAL SUBROUTINE CHKASS(LDEV);                               <<00552>>16520000
VALUE LDEV;                                                    <<00552>>16525000
INTEGER LDEV;                                                  <<00552>>16530000
BEGIN                                                          <<00552>>16535000
   LOCK'ASS'TABLE;                                             <<01647>>16540000
   MOVEFROMDSEG (@ASSOC, ASS'DST, LDEV * ASS'ENTRYSIZE,        <<06730>>16545000
                 ASS'ENTRYSIZE);                               <<06730>>16550000
   FREE'ASS'TABLE;                                             <<01647>>16555000
   MOVE BLCLASSNAME:=BLCLASSNAME WHILE AN,1;                   <<00552>>16560000
   CLASSLEN:=TOS-@BLCLASSNAME;                                 <<00552>>16565000
   IF ASSOC(ASS'JIT)<>0 AND                                    <<00552>>16570000
      ASSOC'(ASS'CLASS*2)<>BLCLASSNAME,(CLASSLEN) THEN         <<00552>>16575000
      CHKASS:=TRUE                                             <<00552>>16580000
   ELSE CHKASS:=FALSE;                                         <<00552>>16585000
END;                                                           <<00552>>16590000
$PAGE                                                          <<00552>>16595000
   <<********* SET OPTIONAL PARM VALUES ***************>>      <<SD.00>>16600000
   MOVE BLANKBUF:=%40,%0; <<DEFAULT INPUT BUFFER>>             <<SD.00>>16605000
   IF Q4.PTYPEBIT=0 THEN PTYPE:=0;                             <<SD.00>>16610000
   IF PTYPE>0 THEN                                             <<SD.00>>16615000
      IF Q4.STRINBIT=1 THEN @INBUF:=@STRIN;                    <<SD.00>>16620000
   IF Q4.RESPONSEBIT=1 THEN @OUTBUF:=@RESPONSE;                <<SD.00>>16625000
   @IOUTBUF:=@OUTBUF&LSR(1);                                   <<SD.00>>16630000
   PUSH (Z);   << Check for bank wraparound.                >> <<A8986>>16635000
   IF TOS < @IOUTBUF THEN @IOUTBUF.(0:1) := 1;                 <<A8986>>16640000
   @TBUF:=@BTBUF&LSR(1);                                       <<SD.00>>16645000
   PUSH (Z);   << Check for bank wraparound.                >> <<A8986>>16650000
   IF TOS < @TBUF THEN @TBUF.(0:1) := 1;                       <<A8986>>16655000
   IF (CLASSREQ := REQDEV<0) THEN                              <<06730>>16660000
      BEGIN   <<GET CLASS ENTRY>>                                       16665000
      ENTRY'LENGTH := GET'DEVICE'CLASS (-REQDEV,               <<06730>>16670000
                      ENTRY'ADDRESS);                          <<06730>>16675000
                                                               <<06730>>16680000
  COMMENT -- We need to work with the list of  LDEV's  in  our <<06730>>16685000
DCT entry.  Unfortunately, the length of the list is arbitrary <<06730>>16690000
and varies from entry to entry.  Thus to make a local copy  of <<06730>>16695000
the entry, we must build space for it on the stack.  (We can't <<06730>>16700000
declare an array because the length is unknown at entry).      <<06730>>16705000
;                                                              <<06730>>16710000
      PUSH (S);                                                <<06730>>16715000
      @DCT := TOS + 1;                                         <<06730>>16720000
      TOS := ENTRY'LENGTH;                                     <<06730>>16725000
      ASSEMBLE (ADDS 0);                                       <<06730>>16730000
      MOVEFROMDSEG (@DCT, DCT'DST, ENTRY'ADDRESS,              <<06730>>16735000
                    ENTRY'LENGTH);                             <<06730>>16740000
      MOVE LCLASSNAME := DCT, (4);                             <<06730>>16745000
      BLCLASSNAME(8) := " ";                                   <<06730>>16750000
      SCAN BLCLASSNAME UNTIL "  ", 1;                          <<06730>>16755000
      BPS0 := 0;   << GENMSG termination character.         >> <<06730>>16760000
      END;   <<CLASSREQ>>                                               16765000
   SPOOLDEV:=Q4.SPOOLERBITS > 0;   <<SPOOLER PARMS PASSED>>    <<SD.00>>16770000
   MOVE LFNAME := FNAME, (4);                                           16775000
   BLFNAME (8) := " ";                                                  16780000
   SCAN BLFNAME UNTIL "  ", 1;                                 <<06730>>16785000
   BPS0 := 0;      << GENMSG termination character.         >> <<06730>>16790000
   IF SPOOLDEV THEN                                                     16795000
      BEGIN    << FORMAT JOB NUMBER >>                                  16800000
      BJOBNUMBER :=                                                     16805000
            IF JOBNUM.(0:2) = 1 THEN "S" ELSE "J";                      16810000
      BJOBNUMBER (ASCII (JOBNUM.(2:14), 10, BJOBNUMBER (1)) +1)         16815000
            := 0;                                                       16820000
      END;                                                              16825000
                                                               <<02566>>16830000
<< When a magtape has been configured for automatic >>         <<02566>>16835000
<< allocation, it means that operator intervention is not >>   <<02566>>16840000
<< required for FOPENs which specifically request that >>      <<02566>>16845000
<< device.  The caller will automatically be given that >>     <<02566>>16850000
<< device providing the following conditions are met:  >>      <<02566>>16855000
                                                               <<02566>>16860000
<< 1)  the LDEV is configured as a magtape (type 24) and >>    <<02566>>16865000
<<     the subtype is greater than or equal to %10.      >>    <<02566>>16870000
<< 2)  the LDEV is neither job nor data accepting.       >>    <<02566>>16875000
<< 3)  the FOPEN is for an unlabelled tape.              >>    <<02566>>16880000
<< 4)  the tape drive is not already allocated to        >>    <<02566>>16885000
<<     another user.                                     >>    <<02566>>16890000
<< 5)  for class requests, there can only be one LDEV    >>    <<02566>>16895000
<<     in the class, and if the device is associated, it >>    <<02566>>16900000
<<     must be associated under the same class name.     >>    <<02566>>16905000
                                                               <<02566>>16910000
AUTOALLOC := FALSE;  << Initialize flag >>                     <<02566>>16915000
                                                               <<02566>>16920000
IF CLASSREQ AND DCT'NUM'DEVICES = 1                            <<06730>>16925000
   AND NOT CHKASS (DCT(DCT'FIRST'LDEV)) THEN                   <<06730>>16930000
  BEGIN  <<ONLY ONE DEVICE IN THIS CLASS>>                     <<TL.03>>16935000
  DEVTOCONSIDER := DCT(DCT'FIRST'LDEV);                        <<06730>>16940000
  GO TO AUTO;                                                  <<TL.03>>16945000
  END;                                                         <<TL.03>>16950000
IF NOT CLASSREQ THEN                                           <<TL.03>>16955000
  BEGIN                                                        <<TL.03>>16960000
  DEVTOCONSIDER:=REQDEV;                                       <<TL.03>>16965000
AUTO:  <<POSSIBLE AUTOMATICALLY ALLOCATED DEVICE>>             <<TL.03>>16970000
    LPDT'INDEX := DEVTOCONSIDER * INTEGER (LPDT'ENTRY'SIZE);   <<06730>>16975000
    IF LABELED = 1 AND SYSTAPEAVR = 1 THEN                     <<07050>>16980000
       GO NORMAL;       << Labelled tape request >>            <<02566>>16985000
    IF NOT GETDEV (DEVTOCONSIDER, LDT'DST, LDT)                <<06730>>16990000
       THEN GO NORMAL;  << Can't get LDT entry >>              <<02566>>16995000
    IF NOT LPDT'AUTO'ALLOC THEN GO NORMAL;                     <<06730>>17000000
    IF LPDT'JOB'ACCEPT OR LPDT'DATA'ACCEPT THEN GO NORMAL;     <<06730>>17005000
    AUTOALLOC := TRUE;   << Unique unlabelled device req.   >> <<A8986>>17010000
    RESP:=OKAY;                                                <<TL.03>>17015000
NORMAL: <<CONTINUE WITH NORMAL PROCESSING>>                    <<TL.03>>17020000
    END;                                                       <<TL.03>>17025000
   DO                                                                   17030000
      BEGIN                                                             17035000
      RESP:=OKAY;                                              <<01115>>17040000
      IOUTBUF := 0;   << In case it was -1 last time.       >> <<A8986>>17045000
      IF AUTOALLOC THEN                                        <<A8986>>17050000
         BEGIN  << See if PTYPE is consistent w/ auto alloc >> <<A8986>>17055000
         CASE PTYPE OF                                         <<A8986>>17060000
            BEGIN                                              <<A8986>>17065000
                                                               <<A8986>>17070000
            ;                     << 0 -- no parm request.  >> <<A8986>>17075000
            AUTOALLOC := FALSE;   << 1 -- retn is numeric,  >> <<A8986>>17080000
                                  <<      op must provide.  >> <<A8986>>17085000
            IOUTBUF := TRUE;      << 2 -- retn is Y/N ==> Y >> <<A8986>>17090000
            AUTOALLOC := FALSE;   << 3 -- retn is string,   >> <<A8986>>17095000
                                  <<      op must provide.  >> <<A8986>>17100000
            END;    << CASE statement.                      >> <<A8986>>17105000
         IF <<still>> AUTOALLOC THEN GO CHECKDEV;              <<A8986>>17110000
         END;   << See if PTYPE is consistent w/ auto alloc >> <<A8986>>17115000
      IF CLASSREQ THEN                                                  17120000
         BEGIN                                                          17125000
         IF SPOOLDEV THEN                                               17130000
            GENMSG(1,211,%10000,SPOOLERNUM,@BJOBNUMBER,        <<0U.EB>>17135000
                @BLFNAME,@BLCLASSNAME,,ASSOC'CLASS(LCLASSNAME),<<00552>>17140000
                0,@ANSWER)                                     <<00552>>17145000
         ELSE                                                           17150000
BEGIN                                                          <<TL.02>>17155000
  IF LABELED =1 AND SYSTAPEAVR = 1 THEN GO LABTAPE;            <<07050>>17160000
            IF PTYPE=0 THEN                                    <<SD.00>>17165000
               GENMSG(1,6,%0,@BLFNAME,@BLCLASSNAME,,,,         <<SD.00>>17170000
                ASSOC'CLASS(LCLASSNAME),0,@ANSWER) <<NO PARM RE<<00552>>17175000
            ELSE                                               <<SD.00>>17180000
               BEGIN <<PARM TYPE REQUEST>>                     <<SD.00>>17185000
               GENMSG(1,276,0,@BLFNAME,@BLCLASSNAME,@INBUF,,,  <<SD.00>>17190000
                ASSOC'CLASS(LCLASSNAME),%15402,@TBUF);<<PARM RE<<00552>>17195000
               PARSEPARM;                                      <<SD.00>>17200000
               END;  <<PARM TYPE REQUEST>>                     <<SD.00>>17205000
END;                                                           <<TL.02>>17210000
     IF RESP=OKAY THEN                                         <<01115>>17215000
       BEGIN                                                   <<01115>>17220000
         IF ANSWER = 0 THEN                                             17225000
            RESP := REJECTED                                   <<06730>>17230000
         ELSE                                                           17235000
            BEGIN   <<SEE IF ANSWER IS IN CLASS>>                       17240000
            I := DCT'FIRST'LDEV - 1;                           <<06730>>17245000
            WHILE (I := I+1) - DCT'FIRST'LDEV <                <<06730>>17250000
                  INTEGER (DCT'NUM'DEVICES) DO                 <<06730>>17255000
               IF ANSWER = INTEGER (DCT(I)) THEN               <<06730>>17260000
               IF CHKASS (INTEGER (DCT(I))) THEN               <<06730>>17265000
               BEGIN                                           <<00552>>17270000
                  ASSOC(ASS'CLASS+4):=0; <<FOR GENMSG>>        <<00552>>17275000
                  GENMSG(1,301,[1/0,3/1,3/0,9/0],ANSWER,       <<00552>>17280000
                         @ASSOC'(ASS'CLASS*2),,,,              <<00552>>17285000
                  ASSOC'CLASS(LCLASSNAME),,,,1);               <<00552>>17290000
               END                                             <<00552>>17295000
               ELSE                                            <<00552>>17300000
                  I := %77770;   <<STOP LOOP>>                 <<06730>>17305000
            IF I - DCT'FIRST'LDEV = INTEGER (DCT'NUM'DEVICES)  <<06730>>17310000
               THEN RESP := INVALID                            <<06730>>17315000
            ELSE RESP := OKAY;                                 <<06730>>17320000
            END;                                                        17325000
       END;                                                    <<01115>>17330000
         DEVTOCONSIDER := ANSWER;                              <<06730>>17335000
         END   <<CLASSREQ>>                                             17340000
      ELSE                                                              17345000
         BEGIN   <<PARTICULAR DEVICE REQUEST>>                          17350000
         IF SPOOLDEV THEN                                               17355000
            GENMSG(1,212,%10010,SPOOLERNUM,@BJOBNUMBER,        <<0U.EB>>17360000
               @BLFNAME,REQDEV,,0,1,@ANSWER)                   <<0U.EB>>17365000
         ELSE                                                           17370000
 BEGIN                                                         <<TL.02>>17375000
  IF LABELED =1 AND SYSTAPEAVR = 1 THEN  <<LABELLED TAPE>>     <<07050>>17380000
  BEGIN                                                        <<TL.02>>17385000
LABTAPE:                                                       <<TL.02>>17390000
    << If user made a specific LDEV request, tell LINKLABEL >> <<02566>>17395000
    IF CLASSREQ THEN  LDEVN := 0                               <<02566>>17400000
                ELSE  LDEVN := DEVTOCONSIDER;                  <<02566>>17405000
    RESP:=LINKLABEL(LDEVN,ACCESS);                             <<TL.02>>17410000
    DEVTOCONSIDER:=LDEVN;                                      <<TL.02>>17415000
    GO GOTDEV;                                                 <<TL.02>>17420000
  END                                                          <<TL.02>>17425000
  ELSE                                                         <<TL.02>>17430000
  BEGIN  <<NO LABEL>>                                          <<TL.02>>17435000
            IF PTYPE=0 THEN                                    <<SD.00>>17440000
            GENMSG(1,5,%01000,@BLFNAME,REQDEV,,,,0,1,          <<0U.EB>>17445000
               @ANSWER) <<NO PARM REQUESTED>>                  <<SD.00>>17450000
            ELSE                                               <<SD.00>>17455000
              BEGIN <<PARM TYPE REQUEST>>                      <<SD.00>>17460000
              GENMSG(1,275,%1000,@BLFNAME,REQDEV,              <<SD.00>>17465000
              @INBUF,,,0,%14002,@TBUF);                        <<SD.00>>17470000
              PARSEPARM;                                       <<SD.00>>17475000
              END;  <<PARM TYPE REQUEST>>                      <<SD.00>>17480000
  END;                                                         <<TL.02>>17485000
 END;                                                          <<TL.02>>17490000
         IF RESP=OKAY THEN                                     <<01115>>17495000
            RESP := IF LOGICAL(ANSWER) THEN OKAY ELSE REJECTED;<<01115>>17500000
         DEVTOCONSIDER := REQDEV;                              <<06730>>17505000
         END;   <<DEVICE REQ>>                                          17510000
CHECKDEV: <<CHECK FOR VALID DEV>>                              <<TL.03>>17515000
GOTDEV:                                                        <<TL.02>>17520000
      SAVE'LDT'SIR := GETSIR (LDT'SIR);                        <<06730>>17525000
      SAVE'LPDT'SIR := GETSIR (LPDT'SIR);                      <<06730>>17530000
      LPDT'INDEX := DEVTOCONSIDER * INTEGER (LPDT'ENTRY'SIZE); <<06730>>17535000
      IF RESP = OKAY THEN                                               17540000
         IF NOT GETDEV (DEVTOCONSIDER, LDT'DST, LDT) THEN      <<06730>>17545000
            RESP := INVALID;                                   <<06730>>17550000
      IF RESP = OKAY THEN                                               17555000
         BEGIN                                                          17560000
         IF LDT'DOWN'PENDING OR NOT LDT'AVAIL'TO'SYS THEN      <<06730>>17565000
            RESP := INVALID;   <<DOWN OR DOWN PENDING>>        <<06730>>17570000
         IF LPDT'VIRTUAL'DEVICE THEN                           <<06730>>17575000
            RESP := INVALID;   <<VDEV OR NON-EXISTENT>>        <<06730>>17580000
                                                               <<06730>>17585000
<< If device is in a foreign disc class, check that a  for- >> <<06730>>17590000
<< eign disc is actually mounted on it.                     >> <<06730>>17595000
                                                               <<03770>>17600000
         IF RESP=OKAY AND CLASSREQ AND                         <<01115>>17605000
            DCT'CLASS'ACC'TYPE = LDT'FOREIGN'DISC THEN         <<06730>>17610000
                IF NOT LPDT'RDY'SER'FRN'DISC OR                <<06730>>17615000
                   LPDT'SERIAL'OR'FOREIGN <> LPDT'FOREIGN      <<06730>>17620000
            THEN  <<NOT FOREIGN>>                              <<01115>>17625000
              BEGIN                                            <<01115>>17630000
              GENMSG(1,272,%10000,DEVTOCONSIDER,,,,,0);        <<01115>>17635000
              RESP:=INVALID;                                   <<01115>>17640000
              END;                                             <<01115>>17645000
<< We will check for a "labeled" serial disc or tape here   >> <<03788>>17650000
<< Since the indentation is screwed up already, we will     >> <<03788>>17655000
<< persist with the tradition (after all we need tradition!)>> <<03788>>17660000
<< Additionally, we will not accept a reply in which the ldev>><<03788>>17665000
<< has a PV at this time (for both class and ldev requests). >><<03788>>17670000
                                                               <<03788>>17675000
CHECK'FOR'AVR := FALSE;      << Default no check >>            <<03788>>17680000
                                                               <<03788>>17685000
IF RESP=OKAY THEN                                              <<03788>>17690000
BEGIN   << Set CHECK'FOR'AVR if tape or serial disc.        >> <<06730>>17695000
    IF LDT'DEVICE'TYPE = LDT'MAG'TAPE                          <<06730>>17700000
      THEN CHECK'FOR'AVR := TRUE                               <<03788>>17705000
                                                               <<03788>>17710000
      ELSE        << not a tape >>                             <<03788>>17715000
      BEGIN                                                    <<03788>>17720000
        DSTAT'RET := REQSTATUS(DEVTOCONSIDER);                 <<03788>>17725000
        IF =  THEN   << = means disc device >>                 <<03788>>17730000
          IF NOT ON'LINE THEN                                  <<03788>>17735000
           BEGIN                                               <<03788>>17740000
              RESP := INVALID;                                 <<03788>>17745000
              GENMSG(1,292,%10000,DEVTOCONSIDER,,,,,0);        <<03788>>17750000
              << LDEV# \ must be on-line before REPLYing>>     <<03788>>17755000
           END                                                 <<03788>>17760000
          ELSE   << An on-line disc.                        >> <<06730>>17765000
            IF LPDT'RDY'SER'FRN'DISC THEN                      <<07229>>17770000
               BEGIN  << Foreign or serial disc.            >> <<07229>>17775000
               IF LPDT'SERIAL'OR'FOREIGN = LPDT'SERIAL         <<07229>>17780000
                  THEN CHECK'FOR'AVR := TRUE                   <<07229>>17785000
               END                                             <<07229>>17790000
            ELSE      << Neither foreign or serial, invalid!>> <<07229>>17795000
               RESP := INVALID;                                <<07229>>17800000
     END; << Not a tape >>                                     <<03788>>17805000
 END;  << Check for tape/serial disc >>                        <<03788>>17810000
           IF RESP=OKAY AND CHECK'FOR'AVR                      <<03788>>17815000
            AND LABELED <> 1 AND SYSTAPEAVR = 1 THEN           <<07050>>17820000
            BEGIN                                              <<TL.03>>17825000
             RELSIR (LPDT'SIR, SAVE'LPDT'SIR);                 <<06730>>17830000
             RELSIR (LDT'SIR, SAVE'LDT'SIR);                   <<06730>>17835000
             IF CKFORLDEV(DEVTOCONSIDER) OR                    <<06027>>17840000
                CKFOREXDATE(DEVTOCONSIDER,ACCESS,0)            <<06027>>17845000
             THEN RESP:=INVALID;                               <<TL.03>>17850000
             SAVE'LDT'SIR := GETSIR (LDT'SIR);                 <<06730>>17855000
             SAVE'LPDT'SIR := GETSIR (LPDT'SIR);               <<06730>>17860000
            END;                                               <<TL.03>>17865000
         END;                                                           17870000
                                                               <<03698>>17875000
      IF RESP = OKAY AND (NOT SPOOLDEV) THEN                            17880000
         BEGIN                                                          17885000
         IF OLDFLAG AND LPDT'DATA'ACCEPT THEN                  <<06730>>17890000
            RESP := OLDDATA                                    <<06730>>17895000
         ELSE                                                           17900000
            BEGIN                                                       17905000
            DISABLE;                                                    17910000
          IF LABELED =1 AND SYSTAPEAVR = 1 THEN GO LABOK;      <<07050>>17915000
            IF LPDT'DEV'OWN'STATE <> LPDT'NOT'OWNED THEN       <<06730>>17920000
               BEGIN   <<OWNED>>                                        17925000
               ENABLE;                                                  17930000
               IF CLASSREQ THEN                                         17935000
                  RESP := INVALID                              <<06730>>17940000
               ELSE                                                     17945000
                  BEGIN                                                 17950000
                  IF JMPIN = INTEGER (LDT'MAIN'PIN) THEN       <<06730>>17955000
                     RESP := REALLOC   <<OWNED BY CALLER>>     <<06730>>17960000
                  ELSE                                                  17965000
                     RESP := INVALID;                          <<06730>>17970000
                  END;                                                  17975000
               END                                                      17980000
            ELSE                                                        17985000
               BEGIN   <<UNOWNED>>                                      17990000
LABOK:                                                         <<TL.02>>17995000
               LPDT'DEV'OWN'STATE := LPDT'RESERVED;            <<06730>>18000000
               ENABLE;                                                  18005000
               END;                                                     18010000
            END;                                                        18015000
         END;                                                           18020000
      RELSIR (LPDT'SIR, SAVE'LPDT'SIR);                        <<06730>>18025000
      RELSIR (LDT'SIR, SAVE'LDT'SIR);                          <<06730>>18030000
     AUTOALLOC:=FALSE; <<IF FAILED AUTOALLOC ASK OP>>          <<TL.03>>18035000
      END UNTIL RESP<>INVALID;                                          18040000
   IF RESP <> REJECTED THEN                                             18045000
      BEGIN                                                             18050000
      ASKOP := TRUE;                                           <<06730>>18055000
      ALLOCDEV := DEVTOCONSIDER;                               <<06730>>18060000
      TYPE := RESP;                                            <<06730>>18065000
      END;                                                              18070000
   END;   <<ASKOP>>                                                     18075000
$PAGE "   ***   ALLOCATE -- Local variable definition   ***"   <<06730>>18080000
$CONTROL SEGMENT = ALLOCATE                                    <<06730>>18085000
                                                               <<06730>>18090000
INTEGER PROCEDURE ALLOCATE (INDX, OLD, OUTPRI, ID, JMPIN,      <<06730>>18095000
                  FORMSG, JNUM, COPIES, DEVINFO,               <<06730>>18100000
                  RETURN'XDD'ADDRESS, FLAGS);                  <<06730>>18105000
    VALUE INDX, OLD, OUTPRI, JMPIN, JNUM, COPIES;              <<06730>>18110000
    INTEGER INDX, OUTPRI, JMPIN, FLAGS, JNUM, COPIES;          <<06730>>18115000
    LOGICAL OLD;                                                        18120000
    INTEGER ARRAY ID, DEVINFO;                                 <<06730>>18125000
    INTEGER POINTER RETURN'XDD'ADDRESS;                        <<06730>>18130000
    BYTE ARRAY FORMSG;                                                  18135000
    OPTION PRIVILEGED, UNCALLABLE;                             <<06730>>18140000
         <<REAL AND VIRTUAL DEVICE ALLOCATION FOR ALL NON-DISK DEVICES>>18145000
         <<INPUT:                                                     >>18150000
         <<      INDX > 0           - LOGICAL DEVICE #                >>18155000
         <<           < 0           - DEVICE CLASS INDEX              >>18160000
         <<      OLD = TRUE         - OLD DEVICE                      >>18165000
         <<          = FALSE        - NEW DEVICE                      >>18170000
         <<      OUTPRI             - OUTPUT SPOOL PRIORITY           >>18175000
         <<      ID                 - USER NAME,ACCT.NAME,JOB NAME,   >>18180000
         <<                            FILE NAME (4 WORDS APIECE) >>    18185000
         <<      JMPIN              - JOB MAIN PROCESS #              >>18190000
         <<      FLAGS            - (0:8)= FLAGS            >> <<TL.02>>18195000
         <<      LABELED          - FLAGS.(7:1)             >> <<TL.02>>18200000
         <<      STDIN'LIST       - FLAGS.(13:1)            >> <<06084>>18205000
         <<      ACCESS           - FLAGS.(14:2)            >> <<TL.02>>18210000
         <<      JNUM               - JOB #                           >>18215000
         <<      FORMSG             - FORMS MSG. STRING TERMINATED BY >>18220000
         <<                            A PERIOD. (SUPPLIED BY USER)   >>18225000
         <<      ACCESS = 0         - INPUT ONLY                      >>18230000
         <<             = 1         - OUTPUT ONLY                     >>18235000
         <<             = 2         - INPUT/OUTPUT                    >>18240000
         <<                                                           >>18245000
         <<OUTPUT:                                                    >>18250000
         <<      ALLOCATE = 0       - OK, IT'S YOURS                  >>18255000
         <<               = -1      - OK, BUT THERE'RE FORMS ON DEV   >>18260000
         <<                           (ONLY FOR INITIAL $STDLIST)     >>18265000
         <<               = -2      - NEW OR REALLOC :DATA            >>18270000
         <<               = -3      - OK, SPOOLED CLASS REQUEST<<00635>>18275000
         <<               = 1       - DEV.(OR VDEV) NOT AVAILABLE     >>18280000
         <<               = 3       - ND CAPABILITY REQUIRED          >>18285000
         <<               = 4       - VDEV REQUESTED NOT OWNED        >>18290000
         <<               = 5       - Couldn't get spoofle  >> <<06730>>18295000
         <<                             extent.             >> <<06730>>18300000
         <<               = 6       - ACCESS VIOLATION                >>18305000
         <<               = 7       - NO ROOM IN XDD                  >>18310000
         <<               = 8       - Couldn't get SDISC XDS>> <<S7474>>18315000
         <<      ACCESSPARM         - MAY BE CHANGED FROM 2 TO 0 OR 1 >>18320000
         <<      DEVINFO(0)         - LDEV OR VDEV ALLOCATED          >>18325000
         <<             (1)-(2)     - LPDT ENTRY                      >>18330000
         <<             (3)-(7)     - LDT ENTRY                       >>18335000
         <<      RETURN'XDD'ADDRESS - ADR. OF XDD ENTRY     >> <<06730>>18340000
         <<     NOTE: DB MUST BE AT STACK - SAME ON EXIT.             >>18345000
   BEGIN                                                                18350000
   EQUATE YES'NO=2; <<FOR YES/NO PARM FROM OPERATOR>>          <<SD.00>>18355000
   EQUATE                                                      <<06730>>18360000
      OK'SPOOLED'CLASS       = -3,   << ALLOCATE returns.   >> <<06730>>18365000
      NEW'OR'REALLOC'DATA    = -2,                             <<06730>>18370000
      OK'SPECIAL'FORMS       = -1,                             <<06730>>18375000
      DEVICE'ALLOCATED       =  0,   << Normal return.      >> <<06730>>18380000
      DEVICE'UNAVAILABLE     =  1,   << Boo, hiss.          >> <<06730>>18385000
           << 2 not used.                                   >> <<06730>>18390000
      NO'ND'CAPABILITY       =  3,                             <<06730>>18395000
      VIRTUAL'DEVC'NOT'YOURS =  4,                             <<06730>>18400000
      NO'SPOOFLE'EXTENT      =  5,                             <<06730>>18405000
      IN'OUT'SPEC'ERROR      =  6,                             <<06730>>18410000
      NO'ROOM'IN'XDD         =  7,                             <<06730>>18415000
      NO'SDISC'XDS           =  8,                             <<S7474>>18420000
                                                               <<06730>>18425000
      INPUTONLY   = 0,     << Part of FLAGS,                >> <<06730>>18430000
      OUTPUTONLY  = 1,     <<   from FOPEN AOPTIONS.        >> <<06730>>18435000
                                                               <<06730>>18440000
      NO'MATCH    = 0,     << For subroutine SCANXDD.       >> <<06730>>18445000
      CLOSE'MATCH = 1,                                         <<06730>>18450000
      EXACT'MATCH = 2,                                         <<06730>>18455000
                                                               <<06730>>18460000
      OPEN        =  TRUE, << Also for SCANXDD.             >> <<06730>>18465000
      READY       = FALSE,                                     <<06730>>18470000
                                                               <<06730>>18475000
      GOTREADY    = 0,     << For OLD file processing.      >> <<06730>>18480000
      GOTOPENED   = 1,                                         <<06730>>18485000
      TRYOPENED   = 2,                                         <<06730>>18490000
      TRYREADY    = 3;                                         <<06730>>18495000
                                                               <<06730>>18500000
   EQUATE PAGE'PRINTER = 8;                                    <<06730>>18505000
                                                               <<06730>>18510000
<< The following two declarations are required by the PXGLO->> <<06730>>18515000
<< BAL $INCLUDE file.  See comments there for details.      >> <<06730>>18520000
                                                               <<06730>>18525000
    LOGICAL ARRAY                                              <<06730>>18530000
       QARRAY(*) = Q + 0;                                      <<06730>>18535000
                                                               <<06730>>18540000
    INTEGER                                                    <<06730>>18545000
       PCBGLOBLOC;    << Required by PXGLOBAL $INCLUDE file >> <<06730>>18550000
                                                               <<02540>>18555000
   INTEGER                                                              18560000
         I,J,K,                                                         18565000
         LDT'INDEX := 0,                                       <<06730>>18570000
         LDTX'INDEX := 0,                                      <<06730>>18575000
         LPDT'INDEX,                                           <<06730>>18580000
         LPDT'ENTRY,                                           <<06730>>18585000
         XDD'DST,                                              <<06730>>18590000
         XDD'SIR,                                              <<06730>>18595000
         BEST'SO'FAR,   << Near match flag for SCANXDD.     >> <<06730>>18600000
         ALLOCDEV,   <<LDEV OR VDEV ALLOCATED>>                         18605000
         DEVTYPE,   <<DEVICE TYPE (OR CLASS TYPE)>>                     18610000
         NEXTDEV,   <<USED AS LDEV WHEN HUMPING THROUGH DEVS.IN CLASS>> 18615000
         ENTRY'ADDRESS,  << DCT-rel. addr of DCT entry.     >> <<06730>>18620000
         ENTRY'LENGTH,   << of Device Class Table entry.    >> <<06730>>18625000
         THIS'LDEV,      << Current LDEV in DCT list.       >> <<06730>>18630000
         TRYFLAG,   <<BEATS ME>>                                        18635000
         REPLYTYPE,   <<TYPE RETURNED BY ASKOP>>                        18640000
         FMSGLGTH  := 0,                                                18645000
         TRYDEV,                                                        18650000
         NUMCOPIES  := 0;    <<#COPIES CALLER WILL GET>>       <<06730>>18655000
                                                               <<06730>>18660000
    LOGICAL ARRAY                                              <<06730>>18665000
       LDT(0:SIZE'OF'LDT'ENTRY-1),                             <<06730>>18670000
       LDTX(0:SIZE'OF'LDTX'ENTRY-1),                           <<06730>>18675000
       XDD(*) = DB + 0;   << Required by XDD $INCLUDE file. >> <<06730>>18680000
    LOGICAL POINTER                                            <<06730>>18685000
       UCAPPTR, << Required by the INCLCAP $INCLUDE file.   >> <<06730>>18690000
       DCT;     << Device Class tbl entry is built on stack.>> <<06730>>18695000
                                                               <<06730>>18700000
   DEFINE ACCESS     = FLAGS.(14:2)#,                          <<06084>>18705000
          STDIN'LIST = LOGICAL(FLAGS.(13:1))#;                 <<06084>>18710000
   DEFINE LABELED=LOGICAL(FLAGS.(7:1))#;                       <<00677>>18715000
   LOGICAL SORFDISC:=FALSE; <<ALLOCATING SER/FORN DISC>>       <<01115>>18720000
   EQUATE INITARRAYSIZE=5;                                     <<03512>>18725000
          <<**WARNING** CHANGING INITARRAYSIZE WILL REQUIRE>>  <<SD.00>>18730000
          <<SAME CHANGE IN SDISCIO>>                           <<SD.00>>18735000
   EQUATE JUSTALLOCATED'ADR=7; <<CHANGNG THIS>>                <<00076>>18740000
          <<WILL REQUIRE SAME CHANGE IN SDISC>>                <<00076>>18745000
   EQUATE JUSTALLOCCELL=0, <<CELLS IN THE INIT>>               <<00239>>18750000
          WRITERINGCELL=1, <<ARRAY FOR SDISC>>                 <<00239>>18755000
          FATALERRCELL =2, <<Extra data seg>>                  <<03512>>18760000
          ERRORLOGCELL =3,                                     <<03512>>18765000
          MEMSIZECELL  =4;                                     <<03512>>18770000
   INTEGER ARRAY TEMPDESC(0:INITARRAYSIZE-1); <<SDISC DESCRIP>><<SD.00>>18775000
   INTEGER SEGNUM := 0,                                        <<S7474>>18780000
           SAVETYPE;                                           <<F7676>>18785000
   BYTE ARRAY MESS(0:18); <<MESSAGE FOR SERIAL DISC>>          <<SD.00>>18790000
   LOGICAL SPOOLFLAG;                                          <<00635>>18795000
   LOGICAL                                                     <<06730>>18800000
         QLOGICAL:=%140000; <<BITMAP OF LOGICAL VARIABLES>>    <<00.DL>>18805000
         <<INITIAL:=TRUE>>                                     <<00.DL>>18810000
         <<REALD:=TRUE>>                                       <<00.DL>>18815000
         <<ALL ELSE:=FALSE>>                                   <<00.DL>>18820000
   DEFINE                                                      <<00.DL>>18825000
         INITIAL=QLOGICAL.(0:1)#, <<INITIAL ALLOCATION>>       <<00.DL>>18830000
         REALD=QLOGICAL.(1:1)#, <<REAL DEVICE>>                <<00.DL>>18835000
         NDCAP=QLOGICAL.(2:1)#, <<USER HAS ND CAPABILITY>>     <<00.DL>>18840000
         <<** UNUSED **>>                                      <<00.DL>>18845000
         <<** UNUSED **>>                                      <<00.DL>>18850000
         <<** UNUSED **>>                                      <<00.DL>>18855000
         CLASSREQ=QLOGICAL.(6:1)#, <<REQUEST IS BY CLASS>>     <<00.DL>>18860000
         OLDREQ=QLOGICAL.(7:1)#, <<OLD DEVICE REQUEST>>        <<00.DL>>18865000
         RESTART=QLOGICAL.(8:1)#,                              <<00.DL>>18870000
         FORMSFLAG=QLOGICAL.(9:1)#,                            <<00.DL>>18875000
         OPFLAG=QLOGICAL.(10:1)#, <<OPERATOR INTERVENTION>>    <<00.DL>>18880000
         ASKFORMS=QLOGICAL.(11:1)#,                            <<00.DL>>18885000
         OPREQD=QLOGICAL.(12:1)#, <<OP INTERVENTION REQ'D>>    <<00.DL>>18890000
         UPDATEXDD=QLOGICAL.(13:1)#, <<XDD MUST BE OR HAS>>    <<00.DL>>18895000
                                     <<BEEN UPDATED>>          <<00.DL>>18900000
         GOTSEXT=QLOGICAL.(14:1)#, <<GOT SPOOL EXTENT>>        <<00.DL>>18905000
         FRESERVED=QLOGICAL.(15:1)#; <<SS HAS BEEN SET TO 3>>  <<00.DL>>18910000
                                                               <<06730>>18915000
   DEFINE                                                      <<06730>>18920000
         OWNEDBYCALLER = JMPIN = INTEGER (LDT'MAIN'PIN) AND    <<06730>>18925000
                         (LPDT'DEV'OWN'STATE = LPDT'OWNED      <<06730>>18930000
                            OR LDTX'SERIAL'OR'FOREIGN)#;       <<06730>>18935000
                                                               <<06730>>18940000
   LOGICAL                                                     <<06730>>18945000
      FOUND'IT,       << Flag for match in SCANXDD.         >> <<06730>>18950000
      JOB'TYPE,       << Funct. compat. for JNUM parm.      >> <<06730>>18955000
      SAVE'LDT'SIR,                                            <<06730>>18960000
      SAVE'LDTX'BASE,                                          <<06730>>18965000
      SAVE'DCT'SIR,                                            <<06730>>18970000
      SAVE'LPDT'SIR,                                           <<06730>>18975000
      SAVE'XDD'SIR;                                            <<06730>>18980000
   LOGICAL LOCKED := FALSE;  << LOCK DRIVE FLAG >>             <<03546>>18985000
   LOGICAL POINTER                                             <<06730>>18990000
      CLOSE'IDD'SUBENTRY,      << See comments in Old Req.  >> <<06730>>18995000
      SAVE'SUBENTRY'ADDRESS,   << See comments in SCANXDD.  >> <<06730>>19000000
      XDD'ADDRESS := 0,        << Segment-relative offset   >> <<06730>>19005000
                               <<   of chosen subentry.     >> <<06730>>19010000
      XDD'COMPARE'ID,          << See comments in SCANXDD.  >> <<06730>>19015000
      XDD'HEAD;                << Req'd by XDD $INCLUDE file>> <<06730>>19020000
   LOGICAL ARRAY                                               <<06730>>19025000
         USERN(*) = ID(0),                                     <<04973>>19030000
         ACCNT(*) = ID(4),                                     <<04973>>19035000
         JOBN(*)  = ID(8),                                     <<04973>>19040000
         FNAME(*) = ID(12),                                    <<04973>>19045000
         QID(0:15) = Q,   <<LOCAL VERSION OF ID>>                       19050000
                                                               <<06730>>19055000
<< The following two arrays hold local copies of an XDD sub->> <<06730>>19060000
<< entry.  XDD'SUBENTRY must be an indirect array (see com- >> <<06730>>19065000
<< ments in SCANXDD).  SAVE'XDD'SUBENTRY holds a near match >> <<06730>>19070000
<< subentry (see comments in the Old Request processor)  in >> <<06730>>19075000
<< case an exact match can't be found.                      >> <<06730>>19080000
                                                               <<06730>>19085000
         XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY-1),               <<06730>>19090000
         SAVE'XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY-1);          <<06730>>19095000
                                                               <<06730>>19100000
   DOUBLE ARRAY                                                <<06730>>19105000
         XDD'DSUBENTRY(*) = XDD'SUBENTRY;  << Req'd symbol. >> <<06730>>19110000
                                                               <<06730>>19115000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>19120000
                                                               <<06730>>19125000
SUBROUTINE DEF'MOVETODSEG;                                     <<06730>>19130000
                                                                        19135000
$PAGE "   ***   ALLOCATE -- Subroutine CREATESUBENTRY   ***"   <<06730>>19140000
SUBROUTINE CREATESUBENTRY;                                     <<06730>>19145000
                                                               <<06730>>19150000
BEGIN COMMENT --                                               <<06730>>19155000
  CREATESUBENTRY is the first of three steps required to get a <<06730>>19160000
new subentry entered into the XDD.  This step assumes the  ex- <<06730>>19165000
istence and availability of a local subentry image, XDD'SUBEN- <<06730>>19170000
TRY.  It zeros out the image (thereby satisfying the  require- <<06730>>19175000
ments  of a non-spoolfile subentry), then fills in some of the <<06730>>19180000
fields. The second step, performed by ALLOCATE, fills in other <<06730>>19185000
areas of the image. Finally, ALLOCATE calls SPUTXDD (the third <<06730>>19190000
step), which fills in even more, allocates space in  the  XDD, <<06730>>19195000
and moves the image in.                                        <<06730>>19200000
                                                               <<06730>>19205000
Special considerations:  DB must be at the stack.              <<06730>>19210000
;                                                              <<06730>>19215000
                                                               <<06730>>19220000
UPDATEXDD := TRUE;                                             <<06730>>19225000
                                                               <<06730>>19230000
<< Zero out the image first.                                >> <<06730>>19235000
                                                               <<06730>>19240000
XDD'SUBENTRY := 0;                                             <<06730>>19245000
MOVE XDD'SUBENTRY(1) := XDD'SUBENTRY, (SIZE'OF'XDD'SUBENTRY-1);<<06730>>19250000
                                                               <<06730>>19255000
IF OLDREQ THEN                                                 <<06730>>19260000
   BEGIN                                                       <<06730>>19265000
   XDDS'SPOOL'STATE := XDDS'READY;                             <<06730>>19270000
   XDDS'OUTPUT'PRIORITY := 0;                                  <<06730>>19275000
   END                                                         <<06730>>19280000
ELSE                                                           <<06730>>19285000
   BEGIN   << New file.                                     >> <<06730>>19290000
   XDDS'SPOOL'STATE := XDDS'OPEN;                              <<06730>>19295000
   XDDS'OUTPUT'PRIORITY := OUTPRI;                             <<06730>>19300000
   END;                                                        <<06730>>19305000
IF REALD THEN                                                  <<06730>>19310000
   BEGIN   << Real device.                                  >> <<06730>>19315000
   XDDS'CLASS := FALSE;                                        <<06730>>19320000
   XDDS'DEVICE := ALLOCDEV;                                    <<06730>>19325000
   END                                                         <<06730>>19330000
ELSE                                                           <<06730>>19335000
   BEGIN   << Virtual device (spoolfile).                   >> <<06730>>19340000
   XDDS'CLASS := (INDX < 0);                                   <<06730>>19345000
   XDDS'DEVICE := \INDX\;                                      <<06730>>19350000
   XDDS'VIRTUAL'LDEV := ALLOCDEV;                              <<06730>>19355000
   IF NOT OLDREQ THEN ODDS'NUMBER'COPIES := NUMCOPIES;         <<06730>>19360000
   END;                                                        <<06730>>19365000
XDDS'JOB'NUMBER := JNUM;                                       <<06730>>19370000
XDDS'JOB'TYPE := JOB'TYPE;                                     <<06730>>19375000
                                                               <<06730>>19380000
<< Note:  The following statement depends  heavily  on  the >> <<06730>>19385000
<< internal  structure  of  the table and the format of the >> <<06730>>19390000
<< data passed in ALLOCATE's ID parameter, namely that  the >> <<06730>>19395000
<< user,  account,  job and file name fields are four words >> <<06730>>19400000
<< each and are contiguous in the order named.              >> <<06730>>19405000
                                                               <<06730>>19410000
MOVE XDDS'USER'NAME := ID, (16);                               <<06730>>19415000
ODDS'FORMS'IN'FILE := (FMSGLGTH <> 0);                         <<06730>>19420000
END;   << of CREATESUBENTRY.                                >> <<06730>>19425000
$PAGE "   ***   ALLOCATE -- Subroutine GETVDEV   ***"          <<06730>>19430000
INTEGER SUBROUTINE GETVDEV;                                             19435000
   BEGIN                                                                19440000
   GETVDEV := 0;                                                        19445000
   LPDT'ENTRY := 0;                                            <<06730>>19450000
   WHILE (LPDT'ENTRY := LPDT'ENTRY + 1) <=                     <<06730>>19455000
         INTEGER (LPDT'MAX'ENTRIES) DO                         <<06730>>19460000
      BEGIN   << Step through looking for avail. virt. dev. >> <<06730>>19465000
      LPDT'INDEX := LPDT'ENTRY * INTEGER (LPDT'ENTRY'SIZE);    <<06730>>19470000
      IF LPDT'VIRTUAL'DEVICE THEN                              <<06730>>19475000
         BEGIN  <<VDEV>>                                                19480000
         DISABLE;                                                       19485000
         IF LPDT'DEV'OWN'STATE = LPDT'NOT'OWNED THEN           <<06730>>19490000
            BEGIN                                                       19495000
            LPDT'DEV'OWN'STATE := LPDT'RESERVED;               <<06730>>19500000
            ENABLE;                                                     19505000
            GETVDEV := LPDT'ENTRY;                             <<06730>>19510000
            FRESERVED := TRUE;                                 <<06730>>19515000
            LPDT'ENTRY := LPDT'MAX'ENTRIES + 1;                <<06730>>19520000
            END;                                                        19525000
         ENABLE;                                                        19530000
         END;                                                           19535000
      END;    << Step through table...                      >> <<06730>>19540000
   END;  <<GETVDEV>>                                                    19545000
                                                                        19550000
$PAGE "   ***   ALLOCATE -- Subroutine GETLDT'LPDT   ***"      <<06730>>19555000
LOGICAL SUBROUTINE GETLDT'LPDT (LDEV);                         <<06730>>19560000
   VALUE   LDEV;                                               <<06730>>19565000
   INTEGER LDEV;                                               <<06730>>19570000
                                                               <<06730>>19575000
BEGIN COMMENT --                                               <<06730>>19580000
  Returns LDT and LDTX entries  to  local  arrays.  Tests  for <<06730>>19585000
valid LPDT entry.  Device type field in local LDT entry is re- <<06730>>19590000
placed by serial disc or foreign disc access type if  applica- <<06730>>19595000
ble.                                                           <<06730>>19600000
;                                                              <<06730>>19605000
GETLDT'LPDT := FALSE;                                          <<06730>>19610000
MOVEFROMDSEG (@LDT, LDT'DST, 0, SIZE'OF'LDT'ENTRY);            <<06730>>19615000
LPDT'INDEX := (LPDT'ENTRY := LDEV) * INTEGER (LPDT'ENTRY'SIZE);<<06730>>19620000
SAVE'LDTX'BASE := LDTX'BASE;                                   <<06730>>19625000
MOVEFROMDSEG (@LDTX, LDT'DST, INTEGER (SAVE'LDTX'BASE) +       <<06730>>19630000
   LPDT'ENTRY * SIZE'OF'LDTX'ENTRY, SIZE'OF'LDTX'ENTRY);       <<06730>>19635000
                                                               <<06730>>19640000
<< The GETDEV calls return table entries and make some mys- >> <<06730>>19645000
<< terious validity check.  Because we now use system table >> <<06730>>19650000
<< pointers, we don't need the local LPDT entry (it goes in >> <<06730>>19655000
<< the LDT entry because GETDEV needs SOMEplace to put it). >> <<06730>>19660000
<< We retain its GETDEV call just in case someone somewhere >> <<06730>>19665000
<< needs it.                                                >> <<06730>>19670000
                                                               <<06730>>19675000
IF GETDEV (LDEV, LPDT'DST, LDT) THEN                           <<06730>>19680000
   IF GETDEV (LDEV, LDT'DST, LDT) THEN                         <<06730>>19685000
      BEGIN                                                    <<06730>>19690000
      GETLDT'LPDT := TRUE;                                     <<06730>>19695000
      SAVETYPE := LDT'DEVICE'TYPE;   << May change, next.   >> <<F7676>>19700000
      IF CLASSREQ THEN LDT'DEVICE'TYPE := DCT'CLASS'ACC'TYPE   <<F7676>>19705000
      ELSE IF LDT'ACCESS'TYPE = LDT'DIRECT'ACCESS              <<F7676>>19710000
         AND LPDT'NOT'PV'OR'SYS THEN                           <<06730>>19715000
         BEGIN   << Replace hdwe disc type w/ SDISC/FDISC.  >> <<06730>>19720000
         IF LPDT'SERIAL'OR'FOREIGN = LPDT'SERIAL THEN          <<06730>>19725000
            LDT'DEVICE'TYPE := LDT'SERIAL'DISC                 <<06730>>19730000
         ELSE LDT'DEVICE'TYPE := LDT'FOREIGN'DISC;             <<06730>>19735000
         END;                                                  <<06730>>19740000
      END;   << Valid LDT, LPDT entries.                    >> <<06730>>19745000
END;         << of GETLDT'LPDT.                             >> <<06730>>19750000
                                                                        19755000
$PAGE "   ***   ALLOCATE -- Subroutine ASK   ***"              <<06730>>19760000
SUBROUTINE ASK;                                                         19765000
   BEGIN                                                                19770000
   RELSIR (XDD'SIR, SAVE'XDD'SIR);                             <<06730>>19775000
   RELSIR (LPDT'SIR, SAVE'LPDT'SIR);                           <<06730>>19780000
   RELSIR (DCT'SIR, SAVE'DCT'SIR);                             <<06730>>19785000
   RELSIR (LDT'SIR, SAVE'LDT'SIR);                             <<06730>>19790000
   IF LDT'DEVICE'TYPE = LDT'SERIAL'DISC OR                     <<06730>>19795000
      LDT'DEVICE'TYPE = LDT'FOREIGN'DISC THEN                  <<06730>>19800000
      BEGIN <<ASKOP FOR SDISC AND WRITERING>>                  <<SD.00>>19805000
      MOVE MESS:=",WRITE RING? (Y/N)";                         <<SD.00>>19810000
      MESS(18) := 0;                                           <<06730>>19815000
      IF NOT ASKOP (INDX, FNAME, OLDREQ, ALLOCDEV,             <<06730>>19820000
      REPLYTYPE,JMPIN,,,FLAGS,YES'NO,MESS,                     <<SD.00>>19825000
      TEMPDESC(WRITERINGCELL)) THEN                            <<00239>>19830000
         BEGIN <<REJECTED SDISC>>                              <<SD.00>>19835000
         ALLOCATE := DEVICE'UNAVAILABLE;                       <<06730>>19840000
         GO BAD3;                                              <<SD.00>>19845000
         END;                                                  <<SD.00>>19850000
         IF TEMPDESC(WRITERINGCELL)=0 AND                      <<01737>>19855000
            LDT'DEVICE'TYPE = LDT'FOREIGN'DISC THEN            <<06730>>19860000
            ACCESS := INPUTONLY;                               <<06730>>19865000
      END   <<ASKOP FOR SDISC AND WRITERING>>                  <<SD.00>>19870000
   ELSE                                                        <<SD.00>>19875000
   IF NOT ASKOP (INDX, FNAME, OLDREQ, ALLOCDEV,                <<06730>>19880000
   REPLYTYPE,JMPIN,,,FLAGS)  THEN                              <<00531>>19885000
      BEGIN                                                             19890000
      ALLOCATE := DEVICE'UNAVAILABLE;                          <<06730>>19895000
      GO BAD3;   <<REJECTED>>                                           19900000
      END;                                                              19905000
   IF REPLYTYPE = OPASSIGNED THEN                                       19910000
      FRESERVED := TRUE;   <<FOR FAILURE UNWIND>>              <<06730>>19915000
   IF REPLYTYPE = REALLOC THEN                                          19920000
      INITIAL := FALSE;                                        <<06730>>19925000
   SAVE'LDT'SIR := GETSIR (LDT'SIR);                           <<06730>>19930000
   SAVE'DCT'SIR := GETSIR (DCT'SIR);                           <<06730>>19935000
   SAVE'LPDT'SIR := GETSIR (LPDT'SIR);                         <<06730>>19940000
   GETLDT'LPDT (ALLOCDEV);                                              19945000
   SAVE'XDD'SIR := GETSIR (XDD'SIR);                           <<06730>>19950000
   END;   <<ASK>>                                                       19955000
$PAGE "   ***   ALLOCATE -- Subroutine REJECTLDEV   ***"       <<06730>>19960000
LOGICAL SUBROUTINE REJECTLDEV(TRYDEV);                         <<02540>>19965000
   VALUE TRYDEV;                                               <<02540>>19970000
   INTEGER TRYDEV;                                             <<02540>>19975000
                                                               <<02540>>19980000
<< REJECT SPECIAL CASES OF DEVICES>>                           <<02540>>19985000
<< EG:  AN UNSPOOLED 2680A (EPOC) >>                           <<02540>>19990000
<<      PAGE PRINTER CANNOT BE ALLOCATED>>                     <<02540>>19995000
<<      AS A HOT PRINTER         >>                            <<02540>>20000000
BEGIN                                                          <<02540>>20005000
                                                               <<02540>>20010000
<<>>                                                           <<02540>>20015000
   REJECTLDEV := FALSE;                                        <<02540>>20020000
   IF LDT'DEVICE'TYPE = LDT'PRINTER AND                        <<06730>>20025000
      LPDT'SUBTYPE = PAGE'PRINTER AND                          <<06730>>20030000
      LDT'SPOOL'STATE = LDT'NOT'SPOOLED THEN                   <<06730>>20035000
      REJECTLDEV := TRUE;                                      <<02540>>20040000
END; <<REJECTLDEV>>                                            <<02540>>20045000
                                                               <<02540>>20050000
$PAGE "   ***   ALLOCATE -- Subroutine TRYNEWREALDEV   ***"    <<06730>>20055000
INTEGER SUBROUTINE TRYNEWREALDEV(TRYDEV);                               20060000
    VALUE TRYDEV;                                                       20065000
    INTEGER TRYDEV;                                                     20070000
         <<CHECK SPECIFIC DEVICE FOR UP & UNOWNED.                    >>20075000
         <<INPUT:                                                     >>20080000
         <<      TRYDEV             - LOG.DEV.#                       >>20085000
         <<OUTPUT:                                                    >>20090000
         <<      TRYNEWREALDEV = 0  - UNAVAILABLE                     >>20095000
         <<                    = 1  - FORMS REQD.OR FORMS MOUNTED     >>20100000
         <<                    = 2  - MAG.TAPE                        >>20105000
         <<                    = 3  - OK,SS SET TO 3,(RESERVED)       >>20110000
   BEGIN                                                                20115000
   TRYNEWREALDEV := 0;                                         <<06730>>20120000
   LPDT'INDEX := TRYDEV * INTEGER (LPDT'ENTRY'SIZE);           <<06730>>20125000
   IF LDT'AVAIL'TO'SYS THEN                                    <<06730>>20130000
      BEGIN   <<UP>>                                                    20135000
      IF REJECTLDEV(TRYDEV) THEN RETURN; <<UNAVAIL>>           <<02540>>20140000
   IF LDT'SPECIAL'FORMS OR FMSGLGTH > 0 THEN                   <<06730>>20145000
      FORMSFLAG := TRUE   << Forms req'd or forms mounted.  >> <<06730>>20150000
   ELSE FORMSFLAG := FALSE;                                    <<06730>>20155000
      IF FNAME <> "$S" THEN                                    <<06730>>20160000
         << NEVER ASK OP FOR $STDLIST, FROM ALLOCATE >>                 20165000
         IF FORMSFLAG                                          <<06730>>20170000
            OR LDT'DEVICE'TYPE = LDT'MAG'TAPE                  <<06730>>20175000
            OR LDT'DEVICE'TYPE = LDT'SERIAL'DISC               <<06730>>20180000
            OR LDT'DEVICE'TYPE = LDT'FOREIGN'DISC              <<06730>>20185000
            OR CLASSREQ AND                                    <<08840>>20190000
                   (DCT'CLASS'ACC'TYPE = LDT'SERIAL'DISC LOR   <<06730>>20195000
                   DCT'CLASS'ACC'TYPE = LDT'FOREIGN'DISC)      <<08840>>20200000
            THEN OPFLAG := TRUE                                <<06730>>20205000
            ELSE OPFLAG := FALSE;                              <<06730>>20210000
      DISABLE;                                                          20215000
      IF LPDT'DEV'OWN'STATE = LPDT'NOT'OWNED THEN              <<06730>>20220000
         BEGIN   <<UP&UNOWNED>>                                         20225000
         IF NOT OPFLAG THEN                                    <<06730>>20230000
            BEGIN                                                       20235000
            LPDT'DEV'OWN'STATE := LPDT'RESERVED;               <<06730>>20240000
            ENABLE;                                                     20245000
            TRYNEWREALDEV := 3;   <<RESERVED>>                 <<06730>>20250000
            FRESERVED := TRUE;   <<FOR ERROR UNWINDING>>       <<06730>>20255000
            IF FORMSFLAG THEN   << Devc needs or has forms. >> <<06730>>20260000
               ALLOCATE := OK'SPECIAL'FORMS;                   <<06730>>20265000
            END                                                         20270000
         ELSE                                                           20275000
            BEGIN   <<CAN'T RESERVE IT>>                                20280000
            ENABLE;                                                     20285000
            TRYNEWREALDEV := IF FORMSFLAG THEN 1 ELSE 2;       <<06730>>20290000
            END;                                                        20295000
         END                                                   <<04289>>20300000
         ELSE                                                  <<04289>>20305000
         IF LDT'DEVICE'TYPE = LDT'MAG'TAPE AND                 <<06730>>20310000
            LPDT'DEV'OWN'STATE = LPDT'OWNED THEN               <<06730>>20315000
            TRYNEWREALDEV := 2;                                <<06730>>20320000
      ENABLE;                                                           20325000
      END;                                                              20330000
   END;   <<TRYNEWREALDEV>>                                             20335000
$PAGE "   ***   ALLOCATE -- Subroutine SCANXDD   ***"          <<06730>>20340000
INTEGER SUBROUTINE SCANXDD (HEAD'INDEX, OPEN'OR'READY);        <<06730>>20345000
   VALUE   HEAD'INDEX, OPEN'OR'READY;                          <<06730>>20350000
   INTEGER HEAD'INDEX;                                         <<06730>>20355000
   LOGICAL OPEN'OR'READY;                                      <<06730>>20360000
                                                               <<06730>>20365000
BEGIN COMMENT --                                               <<06730>>20370000
  SCANXDD scans subentries on the XDD chain defined  by  HEAD' <<06730>>20375000
INDEX,  looking  for  one  which matches the properties of the <<06730>>20380000
devicefile ALLOCATE is currently trying to open.  If  OPEN'OR' <<06730>>20385000
READY  is  TRUE,  any subentry must be in the open state to be <<06730>>20390000
considered further.  If it is FALSE, the subentry must  be  in <<06730>>20395000
the  READY  state.  In  either case, this is only the first of <<06730>>20400000
many tests a candidate subentry must pass. These are described <<06730>>20405000
more fully below.                                              <<06730>>20410000
  SCANXDD returns one of three  values,  summarized  here  and <<06730>>20415000
listed below:                                                  <<06730>>20420000
  0 -- No matching subentry was found.                         <<06730>>20425000
  1 -- A "near match" (see below) was found.                   <<06730>>20430000
  2 -- An exact match was found.                               <<06730>>20435000
                                                               <<06730>>20440000
  Now the details:                                             <<06730>>20445000
  No matter whether the caller wants a READY file or  an  OPEN <<06730>>20450000
file,  any  candidate  subentry  must  pass a series of tests. <<06730>>20455000
Failure of almost any test causes that subentry to be discard- <<06730>>20460000
ed and the next one tried.  READY files can have  an  "almost" <<06730>>20465000
or  "near  match"  condition.  If a candidate survives all but <<06730>>20470000
the final test, SCANXDD remembers it.  If no  exact  match  is <<06730>>20475000
found  among  the  remaining  subentries in the chain, SCANXDD <<06730>>20480000
returns the "near match" subentry instead.  This situation  is <<06730>>20485000
described more fully in the next paragraph.                    <<06730>>20490000
  The Old Request processor calls SCANXDD to try to find READY <<06730>>20495000
devicefiles (subentries) in the IDD.  These must  be  spooled, <<06730>>20500000
by  definition,  since  there  is no such thing as a READY un- <<06730>>20505000
spooled devicefile.  The Old  Request  processor  is  probably <<06730>>20510000
looking for :DATA files or :STREAMed jobs.  [On rare occasions <<06730>>20515000
(described in ALLOCATE), it may look  for  OPEN  files  if  it <<06730>>20520000
can't find an appropriate READY one].  :DATA files do not have <<06730>>20525000
job numbers, but do have optional filenames.  A  "near  match" <<06730>>20530000
is  a  :DATA  subentry whose job, user and account names match <<06730>>20535000
those passed in the ID parameter, but whose filename  was  not <<06730>>20540000
specified  (and  is therefore blank) in either the subentry OR <<06730>>20545000
the ID parameter, but not both.  (If both  fields  were  blank <<06730>>20550000
they would match, and we would have an exact match rather than <<06730>>20555000
a near match).  SCANXDD remembers only the first near match it <<06730>>20560000
finds.                                                         <<06730>>20565000
  The New Request processor calls SCANXDD to try to find  OPEN <<06730>>20570000
devicefiles.  The  only  way such files can be new is if users <<06730>>20575000
are re-opening existing new files (such as printers) by  logi- <<06730>>20580000
cal  device number.  OPEN files can be spooled or non-spooled, <<06730>>20585000
so some consistency tests between the OPEN files and  the  de- <<06730>>20590000
vice (ALLOCDEV) currently being considered by ALLOCATE must be <<06730>>20595000
performed.  The "near match" condition doesn't exist for  OPEN <<06730>>20600000
files,  since  they  always  have a job number associated with <<06730>>20605000
them.                                                          <<06730>>20610000
                                                               <<06730>>20615000
Inputs:   HEAD'INDEX.  The index (head entry/4) of the  device <<06730>>20620000
          whose subentry chain is to be searched.              <<06730>>20625000
                                                               <<06730>>20630000
          OPEN'OR'READY.  If TRUE, subentry must be  OPEN,  if <<06730>>20635000
          FALSE, subentry must be READY.                       <<06730>>20640000
                                                               <<06730>>20645000
Returns:  SCANXDD = 0, no matching subentry found,             <<06730>>20650000
                  = 1, a close match (see above) was found,    <<06730>>20655000
                  = 2, an exact match (see above) was found.   <<06730>>20660000
                                                               <<06730>>20665000
          XDD'SUBENTRY.  For close or  exact  match,  contains <<06730>>20670000
          the  matching  subentry.  If  no match, array is not <<06730>>20675000
          changed.                                             <<06730>>20680000
                                                               <<06730>>20685000
          XDD'ADDRESS. Initialized to 0 at start of ALLOCATE,  <<06730>>20690000
          set to XDD segment-relative address of close or  ex- <<06730>>20695000
          act matching subentry if either is found.            <<06730>>20700000
                                                               <<06730>>20705000
Ways and means:  The symbol "XDD'SUBENTRY" is required by  the <<06730>>20710000
                 XDD $INCLUDE file. We have to use it two dif- <<06730>>20715000
                 ferent ways within ALLOCATE.  Everywhere  but <<06730>>20720000
                 in SCANXDD, DB is at the stack and XDD'SUBEN- <<06730>>20725000
                 TRY is a Q-relative indirect array,  a  local <<06730>>20730000
                 copy of a subentry image which will eventual- <<06730>>20735000
                 ly be entered or rewritten back to  the  XDD. <<06730>>20740000
                 In SCANXDD, DB is at the XDD data segment and <<06730>>20745000
                 XDD'SUBENTRY is a pointer to  an  actual  XDD <<06730>>20750000
                 subentry.  Changing  back  and forth requires <<06730>>20755000
                 some fancy footwork, in particular the use of <<06730>>20760000
                 a temporary cell to hold the  Q-relative  ad- <<06730>>20765000
                 dress  of  XDD'SUBENTRY so we can put it back <<06730>>20770000
                 again later.  Note that the Q-relative  array <<06730>>20775000
                 must  be  an  indirect array for this scam to <<06730>>20780000
                 work.  All this magic is handled within SCAN- <<06730>>20785000
                 XDD.                                          <<06730>>20790000
                                                               <<06730>>20795000
Special considerations:  DB must be at  the  stack  at  entry, <<06730>>20800000
                         same at exit.                         <<06730>>20805000
;                                                              <<06730>>20810000
@SAVE'SUBENTRY'ADDRESS := @XDD'SUBENTRY;                       <<06730>>20815000
EXCHANGEDB (XDD'DST);                                          <<06730>>20820000
SCANXDD := BEST'SO'FAR := NO'MATCH;   << Prepare for worst. >> <<06730>>20825000
FOUND'IT := FALSE;                                             <<06730>>20830000
@XDD'HEAD := HEAD'INDEX * INTEGER (XDD0'HEAD'LENGTH);          <<06730>>20835000
@XDD'SUBENTRY := XDDH'FIRST'SUBENTRY;                          <<06730>>20840000
                                                               <<06730>>20845000
WHILE @XDD'SUBENTRY <> XDDS'END'OF'CHAIN AND NOT FOUND'IT DO   <<06730>>20850000
   BEGIN   << Search subentry links on this chain.          >> <<06730>>20855000
   IF OPEN'OR'READY = OPEN THEN                                <<06730>>20860000
      BEGIN   << Caller wants an OPENed file.               >> <<06730>>20865000
      IF XDDS'SPOOL'STATE <> XDDS'OPEN THEN GO TO NEXT'LINK;   <<06730>>20870000
      IF INTEGER(XDDS'JOB'NUMBER) <> JNUM OR                   <<06730>>20875000
         XDDS'JOB'TYPE <> JOB'TYPE THEN GO TO NEXT'LINK;       <<06730>>20880000
      IF LPDT'VIRTUAL'DEVICE THEN                              <<06730>>20885000
         IF INTEGER (XDDS'VIRTUAL'LDEV) <> ALLOCDEV OR         <<06730>>20890000
            XDDSD'DISC'LABEL = 0D THEN GO TO NEXT'LINK         <<06730>>20895000
         ELSE                                                  <<06730>>20900000
      ELSE IF XDDSD'DISC'LABEL <> 0D THEN GO TO NEXT'LINK;     <<06730>>20905000
                                                               <<06730>>20910000
<< All tests passed for OPEN file, this is an exact match.  >> <<06730>>20915000
                                                               <<06730>>20920000
      FOUND'IT := TRUE;                                        <<06730>>20925000
      END     << Caller wants an OPENed file.               >> <<06730>>20930000
   ELSE                                                        <<06730>>20935000
      BEGIN   << Caller wants a READY file.                 >> <<06730>>20940000
      IF XDDS'SPOOL'STATE <> XDDS'READY THEN GO TO NEXT'LINK;  <<06730>>20945000
                                                               <<06730>>20950000
<< XDD'COMPARE'ID is an artifice, used  for  comparing  the >> <<06730>>20955000
<< job,  user,  account (and later file) name fields of the >> <<06730>>20960000
<< candidate subentry with their counterparts passed in via >> <<06730>>20965000
<< ALLOCATE's ID parameter. The method depends a lot on the >> <<06730>>20970000
<< internal structure of the XDD, since the fields are  as- >> <<06730>>20975000
<< sumed to follow each other.  *-*-* CAUTION:  *-*-* Don't >> <<06730>>20980000
<< rewrite the comparisons  below  to use the Compare Bytes >> <<06730>>20985000
<< (CMPB) machine instruction. It won't work in split-stack >> <<06730>>20990000
<< for Q-relative variables (read "QID").                   >> <<06730>>20995000
                                                               <<06730>>21000000
      @XDD'COMPARE'ID := @XDDS'USER'NAME;                      <<06730>>21005000
      IF XDDS'JOB'NUMBER = 0 AND XDDS'JOB'TYPE = 0 THEN        <<J7846>>21010000
         BEGIN   << No job number, must be a :DATA file.    >> <<06730>>21015000
         I := -1;                                              <<06730>>21020000
         WHILE (I := I + 1) < 12 DO                            <<06730>>21025000
               IF XDD'COMPARE'ID(I) <> QID(I) THEN             <<06730>>21030000
                  GO TO NEXT'LINK;                             <<06730>>21035000
         END                                                   <<06730>>21040000
      ELSE IF INTEGER (XDDS'JOB'NUMBER) <> JNUM OR             <<06730>>21045000
              XDDS'JOB'TYPE <> JOB'TYPE THEN GO TO NEXT'LINK;  <<06730>>21050000
                                                               <<06730>>21055000
<< Almost a near match if here.  If we haven't had  a  pre- >> <<06730>>21060000
<< vious  near  match,  a  blank  subentry or QID file name >> <<06730>>21065000
<< field will establish one now.                            >> <<06730>>21070000
                                                               <<06730>>21075000
      IF BEST'SO'FAR = NO'MATCH THEN                           <<06730>>21080000
         IF XDDS'FILE'NAME = "  " OR QID(12) = "  " THEN       <<06730>>21085000
            BEST'SO'FAR := @XDD'SUBENTRY;                      <<06730>>21090000
                                                               <<06730>>21095000
<< Exact match if file names match (blank or not).          >> <<06730>>21100000
                                                               <<06730>>21105000
      I := 11;   << Position before file name fields.       >> <<06730>>21110000
      WHILE (I := I + 1) < 16 DO                               <<06730>>21115000
            IF XDD'COMPARE'ID(I) <> QID(I) THEN                <<06730>>21120000
               GO TO NEXT'LINK;                                <<06730>>21125000
      FOUND'IT := TRUE;                                        <<06730>>21130000
      END;    << Caller wants a READY file.                 >> <<06730>>21135000
                                                               <<06730>>21140000
NEXT'LINK:                                                     <<06730>>21145000
                                                               <<06730>>21150000
   IF NOT FOUND'IT THEN @XDD'SUBENTRY := XDDS'NEXT'SUBENTRY;   <<06730>>21155000
   END;    << WHILE (Search subentry links on this chain).  >> <<06730>>21160000
                                                               <<06730>>21165000
EXCHANGEDB (STACK);                                            <<06730>>21170000
IF FOUND'IT OR BEST'SO'FAR <> NO'MATCH THEN                    <<06730>>21175000
   BEGIN   << Some kind of match.                           >> <<06730>>21180000
   IF FOUND'IT THEN                                            <<06730>>21185000
      BEGIN                                                    <<06730>>21190000
      SCANXDD := EXACT'MATCH;                                  <<06730>>21195000
      @XDD'ADDRESS := @XDD'SUBENTRY;                           <<06730>>21200000
      END                                                      <<06730>>21205000
   ELSE                                                        <<06730>>21210000
      BEGIN                                                    <<06730>>21215000
      SCANXDD := CLOSE'MATCH;                                  <<06730>>21220000
      @XDD'ADDRESS := BEST'SO'FAR;                             <<06730>>21225000
      END;                                                     <<06730>>21230000
   @XDD'SUBENTRY := @SAVE'SUBENTRY'ADDRESS;                    <<06730>>21235000
   MOVEFROMDSEG (@XDD'SUBENTRY, XDD'DST, @XDD'ADDRESS,         <<06730>>21240000
                 SIZE'OF'XDD'SUBENTRY);                        <<06730>>21245000
   END     << Some kind of match.                           >> <<06730>>21250000
ELSE @XDD'SUBENTRY := @SAVE'SUBENTRY'ADDRESS;   << No match >> <<06730>>21255000
                                                               <<06730>>21260000
END;   << of SCANXDD.                                       >> <<06730>>21265000
$PAGE "   ***   ALLOCATE -- Subroutine FINDNEWREALEE   ***"    <<06730>>21270000
LOGICAL SUBROUTINE FINDNEWREALEE;                              <<00.DL>>21275000
         <<SCAN CLASS(INDX) FOR UP,UNOWNED,REALEE.                    >>21280000
         <<OUTPUT:                                                    >>21285000
         <<      FINDNEWREALEE = FALSE - NO DEVICE AVAILABLE         >> 21290000
         <<                  = TRUE  - DEVICE AVAILABLE               >>21295000
         <<    * IF DEV.AVAIL THEN:                                   >>21300000
         <<      OPREQD = FALSE      - NO OP.INTERVENTION REQD.       >>21305000
         <<                            ALLOCDEV SET. LPDT ENTRY       >>21310000
         <<                            RESERVED. (I.E. SS_3)   <<06730>>21315000
         <<             = TRUE       - OP.INTERVENTION REQD.          >>21320000
         <<    * IF DEV.AVAIL.AND OP.INTERVENTION REQD.THEN:          >>21325000
         <<      ASKFORMS = TRUE     - FORMS REQUEST REQD.            >>21330000
         <<               = FALSE    - MAG.TAPE                       >>21335000
   BEGIN                                                                21340000
   FINDNEWREALEE := FALSE;                                     <<06730>>21345000
   ASKFORMS := TRUE;                                           <<06730>>21350000
   THIS'LDEV := DCT'FIRST'LDEV - 1;                            <<06730>>21355000
   WHILE (THIS'LDEV := THIS'LDEV + 1) - DCT'FIRST'LDEV <       <<06730>>21360000
         INTEGER (DCT'NUM'DEVICES) DO                          <<06730>>21365000
      BEGIN                                                             21370000
      TRYDEV := DCT(THIS'LDEV);                                <<06730>>21375000
      GETLDT'LPDT (TRYDEV);                                             21380000
      IF LDT'SPOOL'QUEUES = LDT'QSHUT                          <<06730>>21385000
         AND ((K := TRYNEWREALDEV (TRYDEV)) <> 0) THEN         <<06730>>21390000
         BEGIN   <<TRYDEV IS SOME KIND OF AVAILABLE>>                   21395000
         FINDNEWREALEE := TRUE;   <<AVAILABLE>>                <<06730>>21400000
         IF K=3 THEN                                                    21405000
            BEGIN   <<GOT IT. NO FORMS OR MAGTAPE PROBLEMS>>            21410000
            ALLOCDEV := TRYDEV;                                <<06730>>21415000
            OPREQD := FALSE;                                   <<06730>>21420000
            RETURN;                                                     21425000
            END;                                                        21430000
         OPREQD := TRUE;                                       <<06730>>21435000
         IF K=2 THEN                                                    21440000
            ASKFORMS := FALSE;                                 <<06730>>21445000
          <<TRY AGAIN>>                                                 21450000
         END;                                                           21455000
      END;                                                              21460000
   END;   <<FINDNEWREALEE>>                                             21465000
$PAGE "   ***   ALLOCATE -- Procedure body   ***"              <<06730>>21470000
   PXGLOBAL;   << Required by PXGLOBAL $INCLUDE file.       >> <<06730>>21475000
   ALLOCATE := DEVICE'ALLOCATED;   << Assume the best.      >> <<06730>>21480000
   MOVE QID := ID, (16);                                                21485000
   @UCAPPTR := @PXG'USERATTRIBUTES;                            <<06730>>21490000
   NDCAP := UCAPND;                                            <<06730>>21495000
   RESTART := PXG'RESTART;                                     <<06730>>21500000
   JOB'TYPE := JNUM.(0:2);   << Funct. compat. w/ XDD $IN-  >> <<06730>>21505000
   JNUM := JNUM.(2:14);      << CLUDE file for JNUM parm.   >> <<06730>>21510000
   SAVE'LDT'SIR := GETSIR (LDT'SIR);                           <<06730>>21515000
   SAVE'DCT'SIR := GETSIR (DCT'SIR);                           <<06730>>21520000
   SAVE'LPDT'SIR := GETSIR (LPDT'SIR);                         <<06730>>21525000
   CLASSREQ:=INDX.(0:1);                                       <<00.DL>>21530000
   IF INDX = 0 THEN SUDDENDEATH (SD363);  << Not LDEV or cls >><<07050>>21535000
   IF CLASSREQ THEN                                            <<06730>>21540000
      BEGIN   <<CLASS REQUEST SETUP>>                                   21545000
      IF NOT NDCAP THEN                                        <<06730>>21550000
         BEGIN   <<NO ND CAPABILITY>>                                   21555000
         ALLOCATE := NO'ND'CAPABILITY;                         <<06730>>21560000
         GO BAD2;                                                       21565000
         END;                                                           21570000
      ENTRY'LENGTH := GET'DEVICE'CLASS (-INDX, ENTRY'ADDRESS); <<06730>>21575000
      IF ENTRY'LENGTH = -1 THEN SUDDENDEATH (SD361);           <<07050>>21580000
      PUSH (S);   << Build space for DCT entry on stack.    >> <<06730>>21585000
      @DCT := TOS + 1;                                         <<06730>>21590000
      TOS := ENTRY'LENGTH;                                     <<06730>>21595000
      ASSEMBLE (ADDS 0);   << Room for entire entry.        >> <<06730>>21600000
      MOVEFROMDSEG (@DCT, DCT'DST, ENTRY'ADDRESS,              <<06730>>21605000
                    ENTRY'LENGTH);                             <<06730>>21610000
      ALLOCDEV := DCT(DCT'FIRST'LDEV);                         <<06730>>21615000
      DEVTYPE := DCT'CLASS'ACC'TYPE;                           <<06730>>21620000
      IF NOT GETLDT'LPDT(ALLOCDEV) THEN                                 21625000
         SUDDENDEATH (SD362);   <<BAD DEVICE# IN CLASS TABLE>> <<07050>>21630000
      END                                                               21635000
   ELSE                                                                 21640000
      BEGIN   <<DEVICE REQUEST SETUP>>                                  21645000
      << Check for ND cap.  But OK for $STDIN/LIST by CI.   >> <<04973>>21650000
      IF NOT NDCAP AND NOT STDIN'LIST THEN                     <<06730>>21655000
         BEGIN   <<NO ND CAPABILITY>>                          <<04537>>21660000
         ALLOCATE := NO'ND'CAPABILITY;                         <<06730>>21665000
         GO BAD2;                                              <<04537>>21670000
         END;                                                  <<04537>>21675000
      ALLOCDEV := INDX;                                        <<06730>>21680000
      IF NOT GETLDT'LPDT(ALLOCDEV) THEN                                 21685000
         BEGIN   <<INVALID INDX>>                                       21690000
         SUDDENDEATH (SD363);                                  <<07050>>21695000
         END;                                                           21700000
      DEVTYPE := LDT'ACCESS'TYPE;                              <<06730>>21705000
      END;                                                              21710000
    <<CHECK ACCESS COMPATABILITY WITH DEVTYPE>>                         21715000
   IF DEVTYPE = LDT'SERIAL'IN THEN                             <<06730>>21720000
      BEGIN                                                             21725000
      IF ACCESS = OUTPUTONLY THEN                                       21730000
         BEGIN   <<BAD ACCESS>>                                         21735000
BADACC:                                                                 21740000
         ALLOCATE := IN'OUT'SPEC'ERROR;                        <<06730>>21745000
         GO BAD2;                                                       21750000
         END;                                                           21755000
      ACCESS := INPUTONLY;                                     <<06730>>21760000
      OLDREQ := TRUE;                                          <<06730>>21765000
      END                                                               21770000
   ELSE                                                                 21775000
      IF DEVTYPE = LDT'SERIAL'OUT THEN                         <<06730>>21780000
         BEGIN                                                          21785000
         IF ACCESS = INPUTONLY THEN                                     21790000
            GO BADACC;                                                  21795000
         ACCESS := OUTPUTONLY;                                          21800000
         OLDREQ := FALSE;                                      <<06730>>21805000
         END                                                            21810000
      ELSE                                                              21815000
         BEGIN   <<I/O DEVICE>>                                         21820000
         IF LPDT'VIRTUAL'DEVICE THEN                           <<06730>>21825000
            IF ACCESS = INPUTONLY AND LPDT'VDEV'DIRECTION =    <<06730>>21830000
               LPDT'VDEV'OUTPUT                                <<06730>>21835000
            OR ACCESS = OUTPUTONLY AND LPDT'VDEV'DIRECTION =   <<06730>>21840000
               LPDT'VDEV'INPUT THEN GO TO BADACC;              <<06730>>21845000
         IF ACCESS = INPUTONLY THEN OLDREQ := TRUE             <<06730>>21850000
         ELSE                                                           21855000
            IF ACCESS = OUTPUTONLY THEN OLDREQ := FALSE        <<06730>>21860000
            ELSE                                                        21865000
            IF LPDT'VIRTUAL'DEVICE THEN  <<VIRTUAL DEVICE>>    <<06730>>21870000
               IF LPDT'VDEV'DIRECTION = LPDT'VDEV'OUTPUT THEN  <<06730>>21875000
                  BEGIN                                        <<SP.01>>21880000
                  ACCESS := OUTPUTONLY;                        <<SP.01>>21885000
                  OLDREQ := FALSE;                             <<06730>>21890000
                  END                                          <<SP.01>>21895000
               ELSE                 <<VIRTUAL INPUT DEVICE>>   <<SP.01>>21900000
                  BEGIN                                        <<SP.01>>21905000
                  ACCESS := INPUTONLY;                         <<SP.01>>21910000
                  OLDREQ := TRUE;                              <<06730>>21915000
                  END                                          <<SP.01>>21920000
            ELSE                                               <<SP.01>>21925000
               OLDREQ:=OLD.(15:1);                             <<00.DL>>21930000
         END;                                                           21935000
$PAGE "   ***   ALLOCATE- OLD   ***"                                    21940000
   IF OLDREQ THEN                                              <<06730>>21945000
      BEGIN   <<* * * * * * * * *   O L D   R E Q U E S T   * * * * * >>21950000
      XDD'SIR := IDD'SIR;                                      <<06730>>21955000
      SAVE'XDD'SIR := GETSIR (XDD'SIR);                        <<06730>>21960000
      XDD'DST := IDD'DST;                                      <<06730>>21965000
      IF CLASSREQ THEN                                         <<06730>>21970000
         BEGIN                                                 <<06730>>21975000
                                                               <<06730>>21980000
<< Trying to open an old (existing?) devicefile via a class >> <<06730>>21985000
<< name.  Scan through subentries for  all  LDEV's  in  the >> <<06730>>21990000
<< class  until  we  find  an  exact match (see comments in >> <<06730>>21995000
<< SCANXDD) or run out of subentries.  Remember  the  first >> <<06730>>22000000
<< close  match  we  may find.  If we run out of subentries >> <<06730>>22005000
<< without finding an exact match we'll use any close match >> <<06730>>22010000
<< we found. If there were none of those either, we have to >> <<06730>>22015000
<< ask the operator to assign us a device.                  >> <<06730>>22020000
                                                               <<06730>>22025000
         @CLOSE'IDD'SUBENTRY := NO'MATCH;                      <<06730>>22030000
         K := NO'MATCH;   << To prime the loop below.       >> <<06730>>22035000
         THIS'LDEV := DCT'FIRST'LDEV - 1;                      <<06730>>22040000
         WHILE (THIS'LDEV := THIS'LDEV + 1) - DCT'FIRST'LDEV < <<06730>>22045000
            INTEGER (DCT'NUM'DEVICES) AND K <> EXACT'MATCH DO  <<06730>>22050000
            BEGIN   <<LOOP THROUGH CLASS>>                              22055000
            NEXTDEV := DCT(THIS'LDEV);                         <<06730>>22060000
            GETLDT'LPDT (NEXTDEV);                             <<F7676>>22065000
            K := SCANXDD (LDT'XDD'HEAD'INDEX, READY);          <<06730>>22070000
            IF K = EXACT'MATCH THEN                            <<06730>>22075000
               ALLOCDEV := NEXTDEV   <<GOT IT>>                <<06730>>22080000
            ELSE                                                        22085000
               IF K = CLOSE'MATCH AND                          <<06730>>22090000
                  @CLOSE'IDD'SUBENTRY = NO'MATCH THEN          <<06730>>22095000
                  BEGIN   <<FIRST CLOSE MATCH - SAVE IT>>               22100000
                  @CLOSE'IDD'SUBENTRY := @XDD'ADDRESS;         <<06730>>22105000
                  MOVE SAVE'XDD'SUBENTRY := XDD'SUBENTRY,      <<06730>>22110000
                       (SIZE'OF'XDD'SUBENTRY);                 <<06730>>22115000
                  END;                                                  22120000
            END;                                               <<06730>>22125000
         IF K <> EXACT'MATCH THEN                              <<F7676>>22130000
            IF @CLOSE'IDD'SUBENTRY <> NO'MATCH THEN            <<06730>>22135000
               BEGIN   << Close match was found, use it.    >> <<06730>>22140000
               MOVE XDD'SUBENTRY := SAVE'XDD'SUBENTRY,         <<06730>>22145000
                    (SIZE'OF'XDD'SUBENTRY);                    <<06730>>22150000
               ALLOCDEV := XDDS'DEVICE;                        <<06730>>22155000
               @XDD'ADDRESS := @CLOSE'IDD'SUBENTRY;            <<06730>>22160000
               GETLDT'LPDT (ALLOCDEV);                                  22165000
               END                                                      22170000
            ELSE    << No match, operator must find device. >> <<06730>>22175000
               DO BEGIN                                        <<06730>>22180000
                  ASK;                                         <<06730>>22185000
                  END                                          <<06730>>22190000
                 UNTIL REPLYTYPE = OPASSIGNED                  <<06730>>22195000
                       OR SCANXDD (LDT'XDD'HEAD'INDEX, READY)  <<06730>>22200000
                          <> NO'MATCH;                         <<06730>>22205000
         END     << Old devicefile, class request.          >> <<06730>>22210000
      ELSE                                                              22215000
         BEGIN   <<OLD REQ.BY LDEV>>                                    22220000
         IF OWNEDBYCALLER THEN                                          22225000
            BEGIN   <<MUST SUCCEED>>                                    22230000
            SCANXDD (LDT'XDD'HEAD'INDEX, OPEN);                <<06730>>22235000
            END                                                         22240000
         ELSE                                                           22245000
            BEGIN   <<NOT A SIMPLE REALLOCATION>>                       22250000
            IF LPDT'VIRTUAL'DEVICE THEN                        <<06730>>22255000
               BEGIN   << Can't directly alloc. virt. dev.  >> <<06730>>22260000
               ALLOCATE := VIRTUAL'DEVC'NOT'YOURS;             <<06730>>22265000
               GO BADEXIT;                                              22270000
               END;                                                     22275000
             <<AT THIS POINT, MUST BE INITIAL ALLOC,SPOOFLE REALLOC BY>>22280000
             <<LDEV OR A SUDDEN REALLOC DURING ASKOP.                 >>22285000
            DO                                                          22290000
               BEGIN   <<TRY TO FIND READY FILE>>                       22295000
               TRYFLAG := GOTREADY;   <<INIT.FOR LOOP>>        <<06730>>22300000
               IF SCANXDD (LDT'XDD'HEAD'INDEX, READY) =        <<06730>>22305000
                  NO'MATCH THEN DO                             <<06730>>22310000
                     BEGIN   <<TRY TO FIND OPENED FILE>>                22315000
                     TRYFLAG := GOTOPENED;                     <<06730>>22320000
                     IF SCANXDD (LDT'XDD'HEAD'INDEX, OPEN)     <<06730>>22325000
                        = NO'MATCH THEN                        <<06730>>22330000
                        BEGIN   <<ASK OPERATOR>>                        22335000
                        IF NOT NDCAP THEN                      <<06730>>22340000
                           BEGIN   <<NO ND CAPABILITY>>                 22345000
                           ALLOCATE := NO'ND'CAPABILITY;       <<06730>>22350000
                           GO BADEXIT;                                  22355000
                           END;                                         22360000
                        ASK;                                            22365000
                        IF REPLYTYPE = REALLOC THEN                     22370000
                           TRYFLAG := TRYOPENED                <<06730>>22375000
                        ELSE                                            22380000
                           IF REPLYTYPE = OLDDATA THEN                  22385000
                              TRYFLAG := TRYREADY;             <<06730>>22390000
                        << ELSE OPASSIGNED:                             22395000
                              LEAVE TRYFLAG = GOTOPENED,                22400000
                              TO DROP OUT OF LOOP >>                    22405000
                        END;   <<OPERATOR>>                             22410000
                     END                                                22415000
                  UNTIL TRYFLAG<>TRYOPENED                              22420000
               ELSE                                                     22425000
                  IF NOT NDCAP THEN                            <<06730>>22430000
                     BEGIN   <<NO ND CAPABILITY-READY,INITIAL ALLOC>>   22435000
                     ALLOCATE := NO'ND'CAPABILITY;             <<06730>>22440000
                     GO BADEXIT;                                        22445000
                     END;                                               22450000
               END                                                      22455000
            UNTIL TRYFLAG<>TRYREADY;                                    22460000
            END;                                                        22465000
         END;   <<OLD LDEV REQ.>>                                       22470000
      IF @XDD'ADDRESS = 0 THEN                                 <<06730>>22475000
         CREATESUBENTRY                                                 22480000
      ELSE                                                              22485000
         BEGIN                                                          22490000
         IF XDDSD'DISC'LABEL <> 0D THEN                        <<06730>>22495000
            REALD := FALSE;                                    <<06730>>22500000
         IF XDDS'SPOOL'STATE = XDDS'OPEN THEN                  <<06730>>22505000
            INITIAL := FALSE;                                  <<06730>>22510000
         END;                                                           22515000
      IF NOT REALD THEN                                        <<06730>>22520000
         BEGIN   <<SPOOFLE>>                                            22525000
         IF INITIAL THEN                                       <<06730>>22530000
            BEGIN                                                       22535000
            IF ( ALLOCDEV := GETVDEV ) = 0 THEN                         22540000
               BEGIN                                                    22545000
               ALLOCATE := DEVICE'UNAVAILABLE;                 <<06730>>22550000
               GO BADEXIT;                                              22555000
               END;                                                     22560000
            XDDS'VIRTUAL'LDEV := ALLOCDEV;                     <<06730>>22565000
            IF RESTART THEN IDDS'RESTART := TRUE;              <<06730>>22570000
            UPDATEXDD := TRUE;                                 <<06730>>22575000
            END                                                         22580000
         ELSE   << Virtual device re-allocation.            >> <<06730>>22585000
            ALLOCDEV := XDDS'VIRTUAL'LDEV;                     <<06730>>22590000
         END;                                                           22595000
      IF INITIAL THEN                                          <<06730>>22600000
         BEGIN                                                          22605000
         UPDATEXDD := TRUE;                                    <<06730>>22610000
         XDDS'SPOOL'STATE := XDDS'OPEN;                        <<06730>>22615000
         XDDS'JOB'NUMBER := JNUM;                              <<06730>>22620000
         XDDS'JOB'TYPE := JOB'TYPE;                            <<06730>>22625000
         END;                                                           22630000
      IF IDDS'DATA THEN                                        <<06730>>22635000
         ALLOCATE := NEW'OR'REALLOC'DATA;                      <<06730>>22640000
      END    <<OLD REQUEST>>                                            22645000
$PAGE "   ***   ALLOCATE- NEW   ***"                                    22650000
   ELSE                                                                 22655000
      BEGIN   <<* * * * * * * * *   N E W   R E Q U E S T   * * * * * >>22660000
      TOS := FORMSG(49);   << Get FMSG length, limit it.    >> <<06730>>22665000
      FORMSG(49) := ".";                                       <<06730>>22670000
      SCAN FORMSG UNTIL "..", 1;                               <<06730>>22675000
      FMSGLGTH := TOS - @FORMSG;                               <<06730>>22680000
      FORMSG(49) := TOS;   << Restore final byte.           >> <<06730>>22685000
      NUMCOPIES := IF COPIES = 0 THEN 1 ELSE COPIES;    <<COPIES>>      22690000
      IF OUTPRI = 0 THEN OUTPRI := 8;   << Default outpri.  >> <<06008>>22695000
      XDD'DST := ODD'DST;                                      <<06730>>22700000
      XDD'SIR := ODD'SIR;                                      <<06730>>22705000
      SAVE'XDD'SIR := GETSIR (XDD'SIR);                        <<06730>>22710000
      IF CLASSREQ THEN                                         <<06730>>22715000
         BEGIN   <<CLASS REQUEST>>                                      22720000
         SPOOLFLAG := SPOOLEDDEV(INDX);                                 22725000
         IF SPOOLFLAG = 1 THEN                                          22730000
            BEGIN <<SPOOLED CLASS>>                            <<06730>>22735000
               ALLOCATE := OK'SPOOLED'CLASS;                   <<06730>>22740000
               REALD := FALSE;                                 <<06730>>22745000
            END    <<SPOOLED CLASS>>                           <<06730>>22750000
         ELSE                                                           22755000
            BEGIN     <<NOT SPOOLED CLASS>>                    <<06730>>22760000
            IF NUMCOPIES <= 1 THEN                             <<06730>>22765000
               BEGIN   <<NORMAL INITIAL ALLOCATION>>           <<06730>>22770000
               IF NOT FINDNEWREALEE THEN                       <<06730>>22775000
                  BEGIN                                        <<06730>>22780000
                     IF SPOOLFLAG THEN                         <<06730>>22785000
                     REALD := FALSE                            <<06730>>22790000
                  ELSE                                         <<06730>>22795000
                     BEGIN   <<DEVICE UNAVAILABLE>>            <<06730>>22800000
                     ALLOCATE := DEVICE'UNAVAILABLE;           <<06730>>22805000
                     GO BADEXIT;                               <<06730>>22810000
                     END;                                      <<06730>>22815000
                  END                                          <<06730>>22820000
               ELSE   <<OP.INTERVENTION REQD.OR RESERVED>>     <<06730>>22825000
               END                                             <<06730>>22830000
            ELSE                                               <<06730>>22835000
               BEGIN   <<#COPIES>1, TRY FOR SPOOLEE>>          <<06730>>22840000
               IF SPOOLFLAG THEN                               <<06730>>22845000
                  REALD := FALSE                               <<06730>>22850000
               ELSE       << Try for real device and        >> <<06730>>22855000
                  BEGIN   << override number of copies.     >> <<06730>>22860000
                  IF NOT FINDNEWREALEE THEN                    <<06730>>22865000
                     BEGIN                                     <<06730>>22870000
                     ALLOCATE := DEVICE'UNAVAILABLE;           <<06730>>22875000
                     GO BADEXIT;                               <<06730>>22880000
                     END;                                      <<06730>>22885000
                  NUMCOPIES := 1;                              <<06730>>22890000
                  END;                                         <<06730>>22895000
               END;   <<SPOOL TRY>>                            <<06730>>22900000
            END;      <<NOT SPOOLED CLASS>>                    <<06730>>22905000
         END   <<NEW,CLASS STUFF>>                                      22910000
$PAGE                                                          <<06730>>22915000
      ELSE                                                              22920000
         BEGIN   <<NEW,LDEV REQUEST>>                                   22925000
         IF OWNEDBYCALLER THEN                                          22930000
            BEGIN   <<OWNED BY CALLER. LDEV OR VDEV REALLOC>>           22935000
            INITIAL := FALSE;                                  <<06730>>22940000
            IF LPDT'VIRTUAL'DEVICE THEN                        <<06730>>22945000
               REALD := FALSE   <<VDEV REALLOC>>               <<06730>>22950000
            ELSE                                                        22955000
               BEGIN   <<LDEV REALLOC>>                                 22960000
               NUMCOPIES := 1;                                 <<06730>>22965000
               IF FMSGLGTH > 0 OR LDT'SPECIAL'FORMS THEN       <<06730>>22970000
                  BEGIN <<FORMS REQ'D OR FORMS UP>>            <<00.DL>>22975000
                  OPREQD := TRUE;                              <<06730>>22980000
                  ASKFORMS := TRUE;                            <<06730>>22985000
                  END;  <<FORMS REQ'D OR FORMS UP>>            <<00.DL>>22990000
               END;                                                     22995000
            END   <<REALLOC>>                                           23000000
         ELSE                                                           23005000
            BEGIN                                                       23010000
            IF LPDT'VIRTUAL'DEVICE THEN                        <<06730>>23015000
               BEGIN                                           <<06730>>23020000
                                                               <<06730>>23025000
<< ALLOCATE's caller has specified, by LDEV, a virtual  de- >> <<06730>>23030000
<< vice (that is, one which is not configured as a real de- >> <<06730>>23035000
<< vice and is therefore available as a virtual device  for >> <<06730>>23040000
<< open spoolfiles).  This is allowed only when re-allocat- >> <<06730>>23045000
<< ing the device (re-opening it after a previous  call  to >> <<06730>>23050000
<< ALLOCATE  by the same process tree).  Callers cannot di- >> <<06730>>23055000
<< rectly allocate a virtual device, as one has tried to do >> <<06730>>23060000
<< here.                                                    >> <<06730>>23065000
                                                               <<06730>>23070000
               ALLOCATE := VIRTUAL'DEVC'NOT'YOURS;             <<06730>>23075000
               GO BADEXIT;                                              23080000
               END;                                                     23085000
             <<MUST BE INITIAL ALLOC OR SPOOFLE REALLOC BY LDEV>>       23090000
            I := SCANXDD (LDT'XDD'HEAD'INDEX, OPEN);           <<06730>>23095000
            IF I <> NO'MATCH THEN                              <<06730>>23100000
               BEGIN   <<GOT OPENED, MUST BE REALLOC SPOOFLE>>          23105000
               INITIAL := FALSE;                               <<06730>>23110000
               REALD := FALSE;                                 <<06730>>23115000
               ALLOCDEV := XDDS'VIRTUAL'LDEV;                  <<06730>>23120000
               END                                                      23125000
            ELSE                                                        23130000
               BEGIN   <<INITIAL ALLOC>>                                23135000
               IF LDT'SPOOL'QUEUES = LDT'QOPEN THEN            <<06730>>23140000
                  REALD := FALSE  <<SPOOLEE>>                  <<06730>>23145000
               ELSE                                                     23150000
                  BEGIN   <<REALEE>>                                    23155000
                  IF (K := TRYNEWREALDEV(ALLOCDEV)) = 0 THEN   <<06730>>23160000
                     BEGIN   <<DEV.NOT AVAILABLE>>                      23165000
                     ALLOCATE := DEVICE'UNAVAILABLE;           <<06730>>23170000
                     GO BADEXIT;                                        23175000
                     END;                                               23180000
                  IF K <> 3 THEN                                        23185000
                     BEGIN   <<MAGTAPE OR FORMS>>                       23190000
                     OPREQD := TRUE;                           <<06730>>23195000
                     IF K=1 THEN                                        23200000
                        ASKFORMS := TRUE;   <<FORMS>>          <<06730>>23205000
                     END;                                               23210000
                  END;   <<REALEE>>                                     23215000
               END;   <<INITIAL ALLOC>>                                 23220000
            END;                                                        23225000
         END;   <<NEW,LDEV REQ.>>                                       23230000
$PAGE                                                          <<06730>>23235000
       <<STUFF COMMON TO ALL NEW>>                                      23240000
       <<REAL INITIAL                                                   23245000
       << T      T     IF OPREQD THEN ASK FOR FORMS,MAG.TAPE          >>23250000
       <<               ELSE ALLOCDEV SET & RESERVED.                 >>23255000
       << T      F     IF OPREQD THEN ASK FOR FORMS ELSE SIMPLE       >>23260000
       <<               REALLOC OF ALLOCDEV                           >>23265000
       << F      T     GET A NEW VDEV.                                >>23270000
       << F      F     SPOOFLE REALLOC. ALLOCDEV SET TO VDEV.         >>23275000
       <<                                                             >>23280000
       << XDD'ADDRESS=0, except for spoofle realloc by ldev >> <<06730>>23285000
       <<FOR REAL ALLOC, OPREQD SET IF OP.INTERVENTION REQUIRED.      >>23290000
      IF OPREQD THEN                                           <<06730>>23295000
         BEGIN   <<OP.INTERVENTION REQUIRED>>                           23300000
         IF ASKFORMS THEN                                      <<06730>>23305000
            IF FMSGLGTH > 0 THEN                                        23310000
               BEGIN   <<SEND FORMS MESSAGE>>                           23315000
               I := FORMSG(FMSGLGTH);   <<SAVE>>               <<06730>>23320000
               FORMSG(X) := 0;   <<TERM. CHAR. FOR PUTMSG>>    <<06730>>23325000
               CLEAN'MESSAGE(FORMSG,FMSGLGTH);                          23330000
               GENMSG(1,213,%10000,ALLOCDEV,@FORMSG,,,,0);     <<00741>>23335000
               FORMSG (FMSGLGTH) := I;                                  23340000
               END                                                      23345000
            ELSE                                                        23350000
               GENMSG(1,214,%10000,ALLOCDEV);                  <<00552>>23355000
         ASK;                                                           23360000
         END;   <<OP.INTERVENTION. GOT INITIAL OR REALLOC REALEE>>      23365000
      IF INITIAL THEN                                          <<06730>>23370000
         BEGIN   <<CREATE LOCAL ODD SUBENTRY>>                          23375000
         IF NOT REALD THEN                                     <<06730>>23380000
            IF ( ALLOCDEV := GETVDEV ) = 0 THEN                         23385000
               BEGIN                                                    23390000
               ALLOCATE := DEVICE'UNAVAILABLE;                 <<06730>>23395000
               GO BADEXIT;                                              23400000
               END;                                                     23405000
         CREATESUBENTRY;                                                23410000
         IF NOT REALD THEN                                     <<06730>>23415000
            BEGIN    << INITIAL, NEW, SPOOLFILE: GET 1ST EXT >>         23420000
            IF DISKALLOC (0, 1, XDDSD'DISC'LABEL, 0) <> 0 THEN <<06730>>23425000
               BEGIN    << ERR GETTING 1ST EXT FOR SPOOLFILE >>         23430000
               ALLOCATE := NO'SPOOFLE'EXTENT;                  <<06730>>23435000
               GOTO BADEXIT;                                            23440000
               END;                                                     23445000
                                                               <<07050>>23450000
<< Convert LDEV in XDD disc label field to VTAB index.      >> <<07050>>23455000
                                                               <<07050>>23460000
            XDDS'SPOOFLE'VT'INDEX :=                           <<07050>>23465000
                 VTABINX (XDDS'SPOOFLE'VT'INDEX, FALSE);       <<07050>>23470000
            GOTSEXT := TRUE;                                   <<06730>>23475000
            END;                                                        23480000
         END                                                            23485000
      ELSE                                                              23490000
         BEGIN   <<REALLOC>>                                            23495000
         IF @XDD'ADDRESS = 0 THEN                              <<06730>>23500000
            IF SCANXDD (LDT'XDD'HEAD'INDEX, OPEN) = NO'MATCH   <<06730>>23505000
               THEN CREATESUBENTRY;                            <<06730>>23510000
         END;                                                           23515000
      IF REALD THEN                                            <<06730>>23520000
         BEGIN                                                 <<06730>>23525000
         GETLDT'LPDT (ALLOCDEV);                                        23530000
         IF NOT LDT'SPECIAL'FORMS AND FMSGLGTH > 0 OR          <<06730>>23535000
            LDT'SPECIAL'FORMS AND FMSGLGTH = 0 THEN            <<06730>>23540000
            LDT'SPECIAL'FORMS := NOT LDT'SPECIAL'FORMS;        <<06730>>23545000
         END                                                            23550000
      ELSE                                                              23555000
         BEGIN   << Virtual device.                         >> <<06730>>23560000
         IF NOT INITIAL THEN                                   <<06730>>23565000
            BEGIN                                                       23570000
            GETLDT'LPDT (ALLOCDEV);                                     23575000
            IF INTEGER (ODDS'NUMBER'COPIES) < NUMCOPIES THEN   <<06730>>23580000
               BEGIN   << Raised NUMCOPIES during realloc.  >> <<06730>>23585000
               UPDATEXDD := TRUE;                              <<06730>>23590000
               ODDS'NUMBER'COPIES := NUMCOPIES;                <<06730>>23595000
               END;                                                     23600000
            END;                                                        23605000
         END;                                                           23610000
      IF FMSGLGTH > 0 AND NOT ODDS'FORMS'IN'FILE THEN          <<06730>>23615000
         BEGIN   << Subentry doesn't know about forms yet.  >> <<06730>>23620000
         ODDS'FORMS'IN'FILE := TRUE;   << It does now.      >> <<06730>>23625000
         UPDATEXDD := TRUE;                                    <<06730>>23630000
         END;                                                           23635000
      END;   <<NEW REQUEST>>                                            23640000
$PAGE "   ***   COMPLETE ALLOCATE (OLD AND NEW)   ***"                  23645000
   GETLDT'LPDT (ALLOCDEV);  << In case oprat gave us another>> <<06730>>23650000
   IF INITIAL AND REALD AND                                    <<06730>>23655000
      (LDT'DEVICE'TYPE = LDT'SERIAL'DISC OR                    <<06730>>23660000
           LDT'DEVICE'TYPE = LDT'FOREIGN'DISC) THEN            <<06730>>23665000
      BEGIN   << Get and initialize dataseg if serial disc. >> <<03607>>23670000
      IF LDT'DEVICE'TYPE = LDT'SERIAL'DISC THEN                <<06730>>23675000
         BEGIN                                                 <<01115>>23680000
         <<************* GET **************************>>      <<SD.00>>23685000
         SEGNUM := GETDATASEG (MEMSIZE, VDSIZE);               <<SD.00>>23690000
         IF <> THEN                                            <<SD.00>>23695000
            BEGIN <<CAN'T GET DATASEG>>                        <<SD.00>>23700000
            SEGNUM := 0;   << Don't give back resources.    >> <<S7474>>23705000
            ALLOCATE := NO'SDISC'XDS;                          <<S7474>>23710000
            GO TO BADEXIT;                                     <<S7474>>23715000
            END;  <<CAN'T GET DATASEG>>                        <<SD.00>>23720000
         <<************* SAVE IN LDTX *****************>>      <<SD.00>>23725000
         END                                                   <<01115>>23730000
      ELSE                                                     <<01115>>23735000
         SEGNUM := 1;   << Foreign disc.                    >> <<01115>>23740000
      IF NOT LDTX'SERIAL'OR'FOREIGN THEN                       <<06730>>23745000
         BEGIN <<FIRST ALLOCATION>>                            <<SD.01>>23750000
                                                               <<03607>>23755000
<< Lock any CS80 device to prevent the  operator  from  un- >> <<03607>>23760000
<< loading it while it is allocated.  This must be a physi- >> <<06730>>23765000
<< cal I/O request (that is, not to the serial disc  code). >> <<06730>>23770000
<< The same holds for the P'ATTACHIO call at BADEXIT.       >> <<06730>>23775000
                                                               <<03607>>23780000
         IF LDEVTOTYPE(ALLOCDEV) = LDT'CS80'DEVICE THEN        <<06730>>23785000
            BEGIN                                              <<03607>>23790000
            LOCKED := TRUE;    <<set in case of an error>>     <<03607>>23795000
            P'ATTACHIO (ALLOCDEV, 0, 0, 0, LOCK, 0, 0, 0, 1);  <<06730>>23800000
            END;                                               <<03607>>23805000
         LDTX'SERIAL'OR'FOREIGN := TRUE;                       <<06730>>23810000
         LDTX'SDISC'GPT'XDS := SEGNUM;                         <<06730>>23815000
         IF LDT'DEVICE'TYPE = LDT'SERIAL'DISC THEN             <<S7474>>23820000
            BEGIN   << Set a bit ATTACHIO can read.         >> <<S7474>>23825000
            DISABLE;                                           <<S7474>>23830000
            LPDT'SERIAL'DISC := TRUE;                          <<S7474>>23835000
            ENABLE;                                            <<S7474>>23840000
            END;    << Set a bit ATTACHIO can read.         >> <<S7474>>23845000
         MOVETODSEG (LDT'DST, SAVE'LDTX'BASE +                 <<06730>>23850000
            LOGICAL (ALLOCDEV) * SIZE'OF'LDTX'ENTRY, @LDTX,    <<06730>>23855000
            SIZE'OF'LDTX'ENTRY);                               <<06730>>23860000
         <<************* INITIALIZE FOR THIS SUBTYPE **>>      <<SD.00>>23865000
         IF SEGNUM > 0 AND LDT'DEVICE'TYPE = LDT'SERIAL'DISC   <<06730>>23870000
           THEN                                                <<06730>>23875000
            BEGIN <<VALID DATASEG NUMBER>>                     <<SD.00>>23880000
            TEMPDESC(JUSTALLOCCELL) := -1;                     <<00239>>23885000
            TEMPDESC(FATALERRCELL) := 0;                       <<00239>>23890000
            TEMPDESC(ERRORLOGCELL) := 0;                       <<03512>>23895000
            TEMPDESC(MEMSIZECELL) := MEMSIZE;                  <<03512>>23900000
            MOVETODSEG (SEGNUM, JUSTALLOCATED'ADR, @TEMPDESC,  <<06730>>23905000
               INITARRAYSIZE);                                 <<06730>>23910000
            END;  <<VALID DATASEG NUMBER>>                     <<SD.00>>23915000
         END   <<FIRST ALLOCATION>>                            <<SD.01>>23920000
      ELSE                                                     <<SD.01>>23925000
         IF SEGNUM > 0 THEN                                    <<S7474>>23930000
            BEGIN   << Serial/foreign disc, not 1st alloc.  >> <<S7474>>23935000
            IF SEGNUM > 1 THEN                                 <<S7474>>23940000
               RELDATASEG (SEGNUM);   << Serial disc.       >> <<S7474>>23945000
            SEGNUM := 0;                                       <<S7474>>23950000
            END;    << Serial/foreign disc, not 1st alloc.  >> <<S7474>>23955000
      END;  <<GET AND INITIALIZE DATASEG>>                     <<SD.00>>23960000
   IF UPDATEXDD THEN                                           <<06730>>23965000
      BEGIN   <<NEW OR ALTERED ENTRY>>                                  23970000
      IF @XDD'ADDRESS = 0 THEN                                 <<06730>>23975000
         BEGIN   << Add new subentry.                       >> <<06730>>23980000
                                                               <<06730>>23985000
<< SPUTXDD allocates space for our new subentry in the XDD, >> <<06730>>23990000
<< then links it in.  It needs to know:  IDD or ODD (OLDREQ >> <<06730>>23995000
<< means IDD) (1st parm), and whether to link it to an LDEV >> <<06730>>24000000
<< chain or to the class chain (2nd parm, > 0 ==> LDEV, < 0 >> <<06730>>24005000
<< ==> class).  It also needs the new subentry image  (XDD' >> <<06730>>24010000
<< SUBENTRY).  It  returns the XDD segment-relative address >> <<06730>>24015000
<< where the subentry was linked  in  XDD'ADDRESS.  SPUTXDD >> <<06730>>24020000
<< also assigns the devicefile ID (DFID) number.            >> <<06730>>24025000
                                                               <<06730>>24030000
         IF SPUTXDD ((NOT OLDREQ), IF XDDS'CLASS THEN          <<06730>>24035000
                    -XDDS'DEVICE ELSE XDDS'DEVICE,             <<06730>>24040000
                    XDD'SUBENTRY, XDD'ADDRESS) <> 0 THEN       <<06730>>24045000
            BEGIN                                              <<06730>>24050000
            ALLOCATE := NO'ROOM'IN'XDD;                        <<06730>>24055000
            GO BADEXIT;                                                 24060000
            END;                                                        24065000
                                                               <<06730>>24070000
<< SPUTXDD returns ODD/IDD as 1/0 in @XDD'ADDRESS.(0:1). We >> <<06730>>24075000
<< can't use it, so we must remove it.                      >> <<06730>>24080000
                                                               <<06730>>24085000
         @XDD'ADDRESS := @XDD'ADDRESS & LSL(1) & LSR(1);       <<06730>>24090000
         END                                                            24095000
      ELSE                                                              24100000
         BEGIN   << SPUTXDD linked new, we move modified.   >> <<06730>>24105000
         MOVETODSEG (XDD'DST, @XDD'ADDRESS, @XDD'SUBENTRY,     <<06730>>24110000
                     SIZE'OF'XDD'SUBENTRY);                    <<06730>>24115000
         END;                                                           24120000
      END;   <<NEW OR ALTERED ENTRY>>                                   24125000
   IF INITIAL THEN                                             <<06730>>24130000
      IF NOT REALD THEN                                        <<06730>>24135000
         BEGIN   << New virtual device entry.               >> <<06730>>24140000
                                                               <<06730>>24145000
  COMMENT -- The following code builds new virtual device  en- <<06730>>24150000
tries in the LDT and LPDT.  We start with the LDT and LPDT en- <<06730>>24155000
tries for the real LDEV or an LDEV from the class (TRYDEV) de- <<06730>>24160000
pending on how ALLOCATE was called.  These are placed  in  the <<06730>>24165000
corresponding  virtual device entries.  The latter entries are <<06730>>24170000
then modified to make them true virtual device entries (mostly <<06730>>24175000
by setting virtual device and XDD fields in the LPDT). This is <<06730>>24180000
so that anyone who looks at the entries while  the  devicefile <<06730>>24185000
is  open will see as much of a simulation of the corresponding <<06730>>24190000
real device as possible (such as  the  type,  subtype,  record <<06730>>24195000
width, JAID bits, etc.).                                       <<06730>>24200000
  Note -- the LPDT is a memory-resident system table. As a re- <<06730>>24205000
sult, the move from one entry to another must use intermediate <<06730>>24210000
storage.  We choose DEVINFO(1), the same area in which the fi- <<06730>>24215000
nal LPDT entry is eventually returned.                         <<06730>>24220000
;                                                              <<06730>>24225000
         TRYDEV := XDDS'DEVICE;                                <<06730>>24230000
         IF XDDS'CLASS THEN                                    <<06730>>24235000
            BEGIN   << Linked to class chain.               >> <<06730>>24240000
            IF GET'DEVICE'CLASS (XDDS'DEVICE, ENTRY'ADDRESS) = <<07050>>24245000
               -1 THEN SUDDENDEATH (SD364);                    <<07050>>24250000
            MOVEFROMDSEG (@DCT, DCT'DST, ENTRY'ADDRESS,        <<07050>>24255000
               DCT'FIRST'LDEV + 1);   << Minimum entry.     >> <<07050>>24260000
            TRYDEV := DCT(DCT'FIRST'LDEV);                     <<06730>>24265000
            END;                                               <<06730>>24270000
         GETDEV (TRYDEV, LDT'DST, LDT);   << Refills LDT.   >> <<07050>>24275000
         LPDT'INDEX := TRYDEV * INTEGER (LPDT'ENTRY'SIZE);     <<S8651>>24280000
         DISABLE;                                              <<06730>>24285000
         MOVEFROMDSEG (@DEVINFO(1), LPDT'DST, LPDT'INDEX,      <<06730>>24290000
                       LPDT'ENTRY'SIZE);                       <<06730>>24295000
         LPDT'INDEX := ALLOCDEV * INTEGER (LPDT'ENTRY'SIZE);   <<06730>>24300000
         MOVETODSEG (LPDT'DST, LPDT'INDEX, @DEVINFO(1),        <<06730>>24305000
                     LPDT'ENTRY'SIZE);                         <<06730>>24310000
         ENABLE;                                               <<06730>>24315000
                                                               <<06730>>24320000
<< Update appropriate LDT fields for a virtual device entry >> <<06730>>24325000
                                                               <<06730>>24330000
         LDT'FILE'USE'CNT := 0;                                <<06730>>24335000
         LDT'SPECIAL'FORMS := FALSE;                           <<06730>>24340000
                                                               <<06730>>24345000
<< This is a virtual device entry, so the symbols below per->> <<06730>>24350000
<< tain to the spooled FILE rather than a  spooled  DEVICE. >> <<06730>>24355000
<< I don't know if anyone uses this information.            >> <<06730>>24360000
                                                               <<06730>>24365000
         IF OLDREQ                                             <<06730>>24370000
            THEN LDT'SPOOL'STATE := LDT'INPUT'SPOOLED          <<06730>>24375000
            ELSE LDT'SPOOL'STATE := LDT'OUTPUT'SPOOLED;        <<06730>>24380000
         LDT'SPOOL'QUEUES := LDT'QSHUT;                        <<06730>>24385000
         IF XDDS'CLASS THEN                                    <<06730>>24390000
            LDT'XDD'HEAD'INDEX := XDD'CLASS'INDEX;             <<06730>>24395000
                                                               <<06730>>24400000
<< Now do LPDT virtual device entry fields.  Since this  is >> <<06730>>24405000
<< a  virtual  device  entry, DISABLE/ENABLE are not needed >> <<06730>>24410000
<< around these statements.  We still  hold  the  LPDT  SIR >> <<06730>>24415000
<< which we acquired at entry to ALLOCATE.                  >> <<06730>>24420000
                                                               <<06730>>24425000
         LPDT'DIT'PTR := 0;   << No DIT for virtual device. >> <<S8651>>24430000
         LPDT'XDD'SUBENTRY'PTR  := @XDD'ADDRESS;               <<06730>>24435000
         LPDT'VIRTUAL'DEVICE    := TRUE;                       <<06730>>24440000
         LPDT'VDEV'DIRECTION    := NOT OLDREQ;                 <<06730>>24445000
         LPDT'NON'SYS'DOMAIN    := FALSE;                      <<06730>>24450000
         LPDT'EOF'TYPE          := LPDT'NO'EOF;                <<06730>>24455000
         LPDT'RDY'SER'FRN'DISC  := FALSE;                      <<06730>>24460000
         LPDT'SERIAL'OR'FOREIGN := FALSE;                      <<06730>>24465000
         END;    << New virtual device entry.               >> <<06730>>24470000
   LDT'MAIN'PIN := JMPIN;                                      <<06730>>24475000
   DISABLE;   << This can be for a real device, so...       >> <<06730>>24480000
   LPDT'DEV'OWN'STATE := LPDT'OWNED;                           <<06730>>24485000
                                                               <<06730>>24490000
<< Because the LPDT is a system table, it is impossible  to >> <<06730>>24495000
<< load its "address" for a MOVE into DEVINFO. Thus we must >> <<06730>>24500000
<< resort to MOVEFROMDSEG instead.                          >> <<06730>>24505000
                                                               <<06730>>24510000
   MOVEFROMDSEG (@DEVINFO(1), LPDT'DST, LPDT'INDEX,            <<06730>>24515000
                 LPDT'ENTRY'SIZE);                             <<06730>>24520000
   ENABLE;                                                     <<06730>>24525000
   LDT'FILE'USE'CNT := LDT'FILE'USE'CNT + 1;                   <<06730>>24530000
   SORFDISC := LDT'DEVICE'TYPE;                                <<06730>>24535000
   IF SORFDISC = LDT'SERIAL'DISC OR SORFDISC = LDT'FOREIGN'DISC<<06730>>24540000
      THEN LDT'DEVICE'TYPE := SAVETYPE; << Restore hdwe type>> <<F7676>>24545000
   PUTDEV (ALLOCDEV, LDT'DST, LDT);                            <<06730>>24550000
   WRITEDSEG'SERIAL (XDD'DST); <<Post our manglings to disc.>> <<w7889>>24555000
   RELSIR (XDD'SIR, SAVE'XDD'SIR);                             <<06730>>24560000
   RELSIR (LPDT'SIR, SAVE'LPDT'SIR);                           <<06730>>24565000
   RELSIR (DCT'SIR, SAVE'DCT'SIR);                             <<06730>>24570000
   RELSIR (LDT'SIR, SAVE'LDT'SIR);                             <<06730>>24575000
   LDT'DEVICE'TYPE := SORFDISC;   << For DEVINFO returns.   >> <<06730>>24580000
    <<SET UP RETURNS>>                                                  24585000
   DEVINFO := ALLOCDEV;                                        <<06730>>24590000
   MOVE DEVINFO(1+LPDT'ENTRY'SIZE) := LDT, (SIZE'OF'LDT'ENTRY);<<06730>>24595000
   @RETURN'XDD'ADDRESS := @XDD'ADDRESS;                        <<06730>>24600000
   @RETURN'XDD'ADDRESS.(0:1) := NOT OLDREQ;   << ODD/IDD    >> <<06730>>24605000
   RETURN;                                                              24610000
BADEXIT:                                                                24615000
   IF LOCKED THEN P'ATTACHIO(ALLOCDEV,0,0,0,UNLOCK,0,0,0,1);   <<06730>>24620000
   IF FRESERVED THEN                                           <<06730>>24625000
      BEGIN                                                             24630000
      LPDT'INDEX := ALLOCDEV * INTEGER (LPDT'ENTRY'SIZE);      <<06730>>24635000
      DISABLE;                                                 <<06730>>24640000
      LPDT'DEV'OWN'STATE := LPDT'NOT'OWNED;                    <<06730>>24645000
      ENABLE;                                                  <<06730>>24650000
      END;                                                              24655000
   IF SEGNUM <> 0 THEN                                         <<S7474>>24660000
      BEGIN   << Unwind serial or foreign disc.             >> <<S7474>>24665000
      IF SEGNUM > 1 THEN                                       <<S7474>>24670000
         BEGIN   << Serial disc.                            >> <<S7474>>24675000
         RELDATASEG (SEGNUM);                                  <<S7474>>24680000
         DISABLE;                                              <<S7474>>24685000
         LPDT'SERIAL'DISC := FALSE;                            <<S7474>>24690000
         ENABLE;                                               <<S7474>>24695000
         END;    << Serial disc.                            >> <<S7474>>24700000
      LDTX'SERIAL'OR'FOREIGN := FALSE;                         <<S7474>>24705000
      LDTX'SDISC'GPT'XDS := 0;                                 <<S7474>>24710000
      MOVETODSEG (LDT'DST, SAVE'LDTX'BASE + LOGICAL (ALLOCDEV) <<S7474>>24715000
         * SIZE'OF'LDTX'ENTRY, @LDTX, SIZE'OF'LDTX'ENTRY);     <<S7474>>24720000
      END;    << Unwind serial or foreign disc.             >> <<S7474>>24725000
   IF GOTSEXT THEN                                             <<06730>>24730000
      << GOT 1ST SPOOLFILE EXTENT: RELEASE IT >>                        24735000
      BEGIN                                                    <<07050>>24740000
                                                               <<07050>>24745000
<< Convert VTAB index in XDD disc label field to LDEV.      >> <<07050>>24750000
                                                               <<07050>>24755000
      XDDS'SPOOFLE'VT'INDEX :=                                 <<07050>>24760000
           LUN (XDDS'SPOOFLE'VT'INDEX, 0);                     <<07050>>24765000
      DISKDEALLOC (0, 0, %201, XDDSD'DISC'LABEL);              <<06730>>24770000
      END;                                                     <<07050>>24775000
   RELSIR (XDD'SIR, SAVE'XDD'SIR);                             <<06730>>24780000
BAD2:                                                                   24785000
   RELSIR (LPDT'SIR, SAVE'LPDT'SIR);                           <<06730>>24790000
   RELSIR (DCT'SIR, SAVE'DCT'SIR);                             <<06730>>24795000
   RELSIR (LDT'SIR, SAVE'LDT'SIR);                             <<06730>>24800000
BAD3:                                                                   24805000
   END;   <<ALLOCATE>>                                                  24810000
$PAGE "   ***   PRIMEDEVICE   ***"                                      24815000
$CONTROL SEGMENT = ALLOCATE                                    <<06730>>24820000
                                                               <<06730>>24825000
LOGICAL PROCEDURE PRIMEDEVICE (LDEV, XDDEP, FORMS);            <<01027>>24830000
   VALUE LDEV, XDDEP, FORMS;                                            24835000
   INTEGER LDEV;          <<LOG. DEV NO.>>                              24840000
   INTEGER POINTER XDDEP; <<XDD ENTRY PNTR (W/SIGN FLAG)>>              24845000
   LOGICAL FORMS;         <<SPECIAL FORMS WERE MOUNTED>>                24850000
   OPTION PRIVILEGED, UNCALLABLE;                                       24855000
                                                                        24860000
<< DOES NECESSARY ATTACHIO SETUP FOR ALLOCATE'D DEVICE <LDEV>:          24865000
   ALWAYS ISSUES ATTACHIO (OPENFILE);                                   24870000
   PRINTS HEADER IF 1ST ALLOC (OF L.P., CD. PUN., OR P/R/P);            24875000
   PERFORMS FORMS ALIGNMENT, IF <FORMS>.                                24880000
   >>                                                                   24885000
                                                                        24890000
BEGIN                                                                   24895000
                                                               <<06730>>24900000
LOGICAL ARRAY                                                  <<06730>>24905000
   LDT (0:SIZE'OF'LDT'ENTRY-1),                                <<06730>>24910000
   LDTX(0:SIZE'OF'LDTX'ENTRY-1);                               <<06730>>24915000
                                                               <<06730>>24920000
INTEGER                                                        <<06730>>24925000
   LDT'INDEX  := 0,                                            <<06730>>24930000
   LDTX'INDEX := 0,                                            <<06730>>24935000
   SAVE'LDT'SIR;                                               <<06730>>24940000
                                                               <<06730>>24945000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<06730>>24950000
                                                               <<06730>>24955000
PRIMEDEVICE := FALSE;                                          <<06730>>24960000
TOS := ATTACHIO (LDEV, 0, 0, 0, 2, 0, 0, 0, %17);              <<S8098>>24965000
DEL;                                                           <<07104>>24970000
IF TOS.(13:3) <> 1 THEN RETURN;   << Check for error.       >> <<07104>>24975000
SAVE'LDT'SIR := GETSIR (LDT'SIR);                              <<06730>>24980000
MOVEFROMDSEG (@LDT, LDT'DST, 0, SIZE'OF'LDT'ENTRY);            <<06730>>24985000
MOVEFROMDSEG (@LDTX, LDT'DST, LDTX'BASE +                      <<06730>>24990000
   LDEV*SIZE'OF'LDTX'ENTRY, SIZE'OF'LDTX'ENTRY);               <<06730>>24995000
MOVEFROMDSEG (@LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,         <<06730>>25000000
   SIZE'OF'LDT'ENTRY);                                         <<06730>>25005000
RELSIR (LDT'SIR, SAVE'LDT'SIR);                                <<06730>>25010000
                                                               <<06730>>25015000
<< Send Job Start to newly-allocated CIPER device.          >> <<06730>>25020000
                                                               <<06730>>25025000
IF LDTX'CIPER'PROTOCOL AND LDT'FILE'USE'CNT = 1 THEN           <<06730>>25030000
   BEGIN                                                       <<06730>>25035000
                                                               <<06730>>25040000
<< 142 = Job Start, P1=1 ==> reset programmable features.   >> <<06730>>25045000
                                                               <<06730>>25050000
   TOS := ATTACHIO (LDEV, 0, 0, 0, 142, 0, 1, 0, 1);           <<06730>>25055000
   DEL;                                                        <<06730>>25060000
   IF TOS.(13:3) <> 1 << normal completion >> THEN RETURN;     <<06730>>25065000
   END;                                                        <<06730>>25070000
IF @XDDEP < 0 THEN                                             <<06730>>25075000
   BEGIN    << OUTPUT DEVICE: [,HEADER] [,FORMSALIGN] >>       <<06730>>25080000
   IF LDT'FILE'USE'CNT = 1 THEN                                <<06730>>25085000
      BEGIN   << First allocation, try to print header.     >> <<06730>>25090000
      TOS := 0;    <<STACK PARMS FOR HEADER CALL>>             <<06730>>25095000
      TOS := @XDDEP.(1:15);    <<MASK OFF ODD BIT>>            <<06730>>25100000
      IF NOT HEADER (*, LDEV, LDT'DEVICE'TYPE,                 <<06730>>25105000
         LDT'RECORD'WIDTH) THEN RETURN;                        <<06730>>25110000
      END;                                                     <<06730>>25115000
   IF FORMS THEN FORMSALIGN (LDEV);    <<ALIGN IF <FORMS>.>>   <<06730>>25120000
   END;    << OUTPUT DEV >>                                    <<06730>>25125000
PRIMEDEVICE := TRUE;                                           <<06730>>25130000
END;    << PRIMEDEVICE >>                                      <<06730>>25135000
$PAGE "   ***   FREEDEVICE   ***"                              <<06730>>25140000
$CONTROL SEGMENT= ALLOCUTIL                                             25145000
                                                                        25150000
PROCEDURE FREEDEVICE(LDEV,WAIT,NOREW);                         <<TL.02>>25155000
   VALUE WAIT,LDEV,NOREW;                                      <<TL.02>>25160000
   INTEGER LDEV;    <<NON-SHARABLE, REAL DEVICE 2 B FREED>>             25165000
   LOGICAL WAIT;    <<WAIT ON CLOSEDEVICE?>>                            25170000
   LOGICAL NOREW;                                              <<07050>>25175000
   OPTION VARIABLE;                                            <<07050>>25180000
   OPTION PRIVILEGED, UNCALLABLE;                                       25185000
BEGIN                                                                   25190000
                                                               <<07050>>25195000
<< Note:  The following EQUATE is a parameter to the  AWAKE >> <<07050>>25200000
<< procedure,  and  represents  a  PCB  event mask position >> <<07050>>25205000
<< shifted right four bits.  It is currently unavailable in >> <<07050>>25210000
<< any $INCLUDE file, which is why it is here!  If the  un- >> <<07050>>25215000
<< derlying  event  mask  (or the AWAKE interface) changes, >> <<07050>>25220000
<< this EQUATE will also have to change.                    >> <<07050>>25225000
                                                               <<07050>>25230000
   EQUATE                                                      <<07050>>25235000
                     JUNKWAIT   = %20;                         <<07050>>25240000
                                                               <<07050>>25245000
   INTEGER           SAVE'LDT'SIR,     <<GETSIR RETURNS>>      <<06730>>25250000
                     LDT'INDEX := 0,                           <<06730>>25255000
                     DUMMY,            << for procedure call >><<02566>>25260000
                     Q4=Q-4,                                   <<TL.02>>25265000
                     LPDT'INDEX;                               <<06730>>25270000
                                                               <<06730>>25275000
   LOGICAL ARRAY     LDT(0:SIZE'OF'LDT'ENTRY-1);               <<06730>>25280000
                                                               <<06730>>25285000
   LOGICAL           NOWOFFLINE  := FALSE,  <<IF DOWN PENDING>><<06730>>25290000
                     FLUSH  := FALSE;  <<COM PEND OR NON-I AND ACCEPT>> 25295000
                                                                        25300000
   LOGICAL LFLAG:=FALSE; <<TAPE LABEL FLAG>>                   <<TL.02>>25305000
                                                               <<06730>>25310000
                                                               <<06730>>25315000
   SUBROUTINE DEF'MOVEFROMDSEG;                                <<06730>>25320000
                                                               <<06730>>25325000
   SUBROUTINE DEF'MOVETODSEG;                                  <<06730>>25330000
                                                               <<06730>>25335000
                                                               <<06730>>25340000
                                                               <<06730>>25345000
   LPDT'INDEX := LDEV * INTEGER (LPDT'ENTRY'SIZE);             <<06730>>25350000
   IF Q4.(15:1)=1 THEN LFLAG:=NOREW;                           <<TL.02>>25355000
   SAVE'LDT'SIR := GETSIR (LDT'SIR);                           <<06730>>25360000
   MOVEFROMDSEG (@LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,      <<06730>>25365000
                 SIZE'OF'LDT'ENTRY);                           <<06730>>25370000
   LDT'FILE'USE'CNT := 0;                                      <<06730>>25375000
   LDT'MAIN'PIN := 0;                                          <<06730>>25380000
   IF LDT'DOWN'PENDING THEN                                    <<06730>>25385000
      BEGIN   << Device is done now, take it down.          >> <<06730>>25390000
      NOWOFFLINE := TRUE;                                               25395000
      LDT'AVAIL'TO'SYS := FALSE;                               <<06730>>25400000
      LDT'DOWN'PENDING := FALSE;                               <<06730>>25405000
      END                                                               25410000
   ELSE                                                                 25415000
      BEGIN                                                             25420000
      DISABLE;                                                 <<06730>>25425000
                                                               <<06730>>25430000
  COMMENT -- The strange code which  follows  is  designed  to <<06730>>25435000
wake DEVREC (a few lines from now) under certain conditions:   <<06730>>25440000
1.  A :DATA, :HELLO or :JOB has been detected (the  EOF  field <<06730>>25445000
    is even -- very table-dependent), -OR-                     <<06730>>25450000
2.  The device is not interactive but is job or data accepting <<06730>>25455000
    (say, a job stream device).                                <<06730>>25460000
;                                                              <<06730>>25465000
      IF LPDT'EOF'TYPE <> 0 AND NOT LPDT'EOF'TYPE              <<06730>>25470000
         OR NOT LPDT'INTERACTIVE AND                           <<06730>>25475000
            (LPDT'JOB'ACCEPT OR LPDT'DATA'ACCEPT) THEN         <<06730>>25480000
         FLUSH := TRUE;                                        <<06730>>25485000
      ENABLE;                                                  <<06730>>25490000
      END;                                                              25495000
   MOVETODSEG (LDT'DST, LDEV*SIZE'OF'LDT'ENTRY, @LDT,          <<06730>>25500000
               SIZE'OF'LDT'ENTRY);                             <<06730>>25505000
   RELSIR (LDT'SIR, SAVE'LDT'SIR);                             <<06730>>25510000
                                                                        25515000
   IF NOWOFFLINE THEN                                                   25520000
      GENMSG(1,250,%10000,LDEV,,,,,0);                         <<0U.EB>>25525000
   IF FLUSH THEN                                                        25530000
      BEGIN                                                             25535000
      DISABLE;                                                          25540000
      LPDT'DEV'OWN'STATE := LPDT'SERVICE'REQ;                  <<06730>>25545000
      LPDT'SERV'REQ'COUNT := LPDT'SERV'REQ'COUNT + 1;          <<06730>>25550000
      ENABLE;                                                           25555000
      AWAKE (SYSDEVRECPCB, JUNKWAIT, 0);                       <<07050>>25560000
      END                                                               25565000
   ELSE                                                                 25570000
      BEGIN                                                             25575000
      IF NOT LDT'CS'DEVICE THEN                                <<06730>>25580000
         IF NOT LFLAG THEN                                     <<02566>>25585000
            BEGIN                                              <<02566>>25590000
            << Clean up density data structure for tapes. >>   <<02566>>25595000
            IF LDT'DEVICE'TYPE = LDT'MAG'TAPE THEN             <<06730>>25600000
               BEGIN                                           <<02566>>25605000
               STORE'DENSITY(LDEV,DUMMY,2);  << Clear fields >><<02566>>25610000
               SET'LPDT'BOT(LDEV,1);   << Set BOT >>           <<02566>>25615000
               END;                                            <<02566>>25620000
                                                               <<02566>>25625000
            << Close device >>                                 <<02566>>25630000
            ATTACHIO(LDEV,0,0,0,4,0,0,0,IF WAIT THEN 1         <<02566>>25635000
                                                ELSE %17);     <<07229>>25640000
            END;                                               <<02566>>25645000
      DISABLE;                                                 <<06730>>25650000
      LPDT'DEV'OWN'STATE := LPDT'NOT'OWNED;                    <<06730>>25655000
      ENABLE;                                                  <<06730>>25660000
      IF NOT (NOWOFFLINE) THEN                                          25665000
         BEGIN                                                          25670000
                                                               <<07050>>25675000
  COMMENT -- We communicate with UCOP  through  some  bits  in <<07050>>25680000
SYSGLOB.  We set a bit saying we are freeing up a device. Then <<07050>>25685000
we see if UCOP is waiting for a device to become free (another <<07050>>25690000
bit).  If so we AWAKEn UCOP, because we have just freed one it <<07050>>25695000
may be able to use.  We also clear the UCOP wait bit.          <<07050>>25700000
;                                                              <<07050>>25705000
         DISABLE;                                              <<07050>>25710000
         SYSDEVAVAIL := TRUE;                                  <<07050>>25715000
         TOS := SYSWAITFORDEV;                                 <<07050>>25720000
         SYSWAITFORDEV := FALSE;                               <<07050>>25725000
         ENABLE;                                               <<07050>>25730000
         IF TOS THEN AWAKE (SYSUCOPPCB, JUNKWAIT, 0);          <<07050>>25735000
         END;                                                           25740000
      END;                                                              25745000
   END;    <<FREEDEVICE>>                                               25750000
$PAGE "   ***   DOUBLETIME   ***"                              <<06730>>25755000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>25760000
                                                               <<06730>>25765000
DOUBLE PROCEDURE DOUBLETIME;                                            25770000
   OPTION PRIVILEGED, UNCALLABLE;                                       25775000
                                                                        25780000
<< RETURNS CURRENT TIME IN FOLLOWING (POSITIVE) DOUBLE-WORD FORMAT:     25785000
   [1/0, 7/YEAR, 9/DAY, 5/HOUR, 6/MIN, 4/QUADSECOND] D.  >>             25790000
                                                                        25795000
BEGIN                                                                   25800000
   TOS := CALENDAR;                                                     25805000
   TOS := CLOCK;                                                        25810000
   << "TASK" NOW IS TO "ELIMINATE" (1).(0:3), (1).(8:2), (2).(0:2),     25815000
      (2).(6:10); COMPRESSING REMAINING FIELDS, RT-JUSTIFIED. >>        25820000
   TOS := TOS &LSL(2);    <<MAKE MIN & SEC ADJACENT>>                   25825000
   TOS := TOS &DLSR(8);    <<SETUP TO MAKE HR & MIN ADJACENT>>          25830000
   TOS := TOS &LSL(2);    <<MAKE HR & MIN ADJACENT>>                    25835000
   TOS := TOS &DLSR(5);    <<MAKE YR & HR ADJACENT>>                    25840000
   DELB;                  <<ALL INFO SHIFTED OUT OF S-1>>               25845000
   TOS := TOS &DLSR(1);    <<RT. JUSTIFY>>                              25850000
                                                                        25855000
   DOUBLETIME := TOS;                                                   25860000
   END;    <<DOUBLETIME>>                                               25865000
$PAGE "   ***   FORS'XDS'DEALLOC   ***"                        <<06730>>25870000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>25875000
                                                               <<06730>>25880000
PROCEDURE FORS'XDS'DEALLOC(LDEV);                              <<03633>>25885000
  VALUE LDEV;                                                  <<03633>>25890000
  INTEGER LDEV;                                                <<03633>>25895000
  OPTION PRIVILEGED,UNCALLABLE;                                <<03633>>25900000
COMMENT                                                        <<03633>>25905000
                                                               <<03633>>25910000
   This procedure is used to deallocate the extra data         <<03633>>25915000
segment used in SDISC.  It is called from DEALLOCATE and       <<03633>>25920000
CLEANTAPE (in LABSEG).  To be called the device (LDEV)         <<03633>>25925000
must be a non system and non Private Volume Disc.              <<03633>>25930000
DB at stack on entry/exit.                                     <<03633>>25935000
                                                               <<03633>>25940000
;                                                              <<03633>>25945000
BEGIN  << Unlock CS80 dev, deallocate SD XDS >>                <<03633>>25950000
  INTEGER LDTX'INDEX := 0,                                     <<06730>>25955000
          LPDT'INDEX;                                          <<06730>>25960000
  INTEGER SEGNUM;                                              <<03633>>25965000
  INTEGER SAVE'LDT'SIR;                                        <<06730>>25970000
                                                               <<06730>>25975000
  LOGICAL ARRAY                                                <<06730>>25980000
     LDT (0:SIZE'OF'LDT'ENTRY-1),   << Just to get to LDTX. >> <<06730>>25985000
     LDTX(0:SIZE'OF'LDTX'ENTRY-1);                             <<06730>>25990000
                                                               <<06730>>25995000
                                                               <<06730>>26000000
  SUBROUTINE DEF'MOVEFROMDSEG;                                 <<06730>>26005000
                                                               <<06730>>26010000
  SUBROUTINE DEF'MOVETODSEG;                                   <<06730>>26015000
                                                               <<06730>>26020000
                                                               <<06730>>26025000
                                                               <<03633>>26030000
LPDT'INDEX := LDEV * INTEGER (LPDT'ENTRY'SIZE);                <<06730>>26035000
                                                               <<03633>>26040000
<< Unlock any CS80 serial or foreign disc.                  >> <<06730>>26045000
                                                               <<03633>>26050000
IF LDEVTOTYPE(LDEV) = LDT'CS80'DEVICE                          <<06730>>26055000
  THEN P'ATTACHIO (LDEV, 0, 0, 0, UNLOCK, 0, 0, 0, 1);         <<06730>>26060000
                                                               <<03633>>26065000
<< Get serial disc XDS number from LDT extension.           >> <<03633>>26070000
                                                               <<03633>>26075000
SAVE'LDT'SIR := GETSIR (LDT'SIR);                              <<06730>>26080000
MOVEFROMDSEG (@LDT, LDT'DST, 0, SIZE'OF'LDT'ENTRY);            <<06730>>26085000
MOVEFROMDSEG (@LDTX, LDT'DST, LDTX'BASE +                      <<06730>>26090000
              LDEV * SIZE'OF'LDTX'ENTRY, SIZE'OF'LDTX'ENTRY);  <<06730>>26095000
SEGNUM := LDTX'SDISC'GPT'XDS;                                  <<06730>>26100000
                                                               <<03633>>26105000
<< Segment exists only if the device is a serial disc,  but >> <<03633>>26110000
<< the  Foreign  Disc Facility uses the LDTX entry as well. >> <<03633>>26115000
<< Thus the LDTX entry must be cleared in any case.         >> <<03633>>26120000
                                                               <<03633>>26125000
LDTX'SERIAL'OR'FOREIGN := FALSE;                               <<06730>>26130000
LDTX'SDISC'GPT'XDS := 0;                                       <<06730>>26135000
MOVETODSEG (LDT'DST, LDTX'BASE + LDEV *                        <<06730>>26140000
            SIZE'OF'LDTX'ENTRY, @LDTX, SIZE'OF'LDTX'ENTRY);    <<06730>>26145000
IF SEGNUM > 1 THEN                                             <<S7474>>26150000
   BEGIN   << Serial disc, release XDS, clear LPDT bit.     >> <<S7474>>26155000
   RELDATASEG (SEGNUM);                                        <<03633>>26160000
   DISABLE;                                                    <<S7474>>26165000
   LPDT'SERIAL'DISC := FALSE;                                  <<S7474>>26170000
   ENABLE;                                                     <<S7474>>26175000
   END;    << Serial disc, release XDS, clear LPDT bit.     >> <<S7474>>26180000
RELSIR (LDT'SIR, SAVE'LDT'SIR);                                <<06730>>26185000
END;   << Unlock CS80 dev, deallocate SD XDS >>                <<03633>>26190000
$PAGE "   ***   DEALLOCATE   ***"                              <<06730>>26195000
$CONTROL SEGMENT = ALLOCUTIL                                   <<06730>>26200000
                                                                        26205000
                                                                        26210000
PROCEDURE DEALLOCATE (DEVPARM);                                         26215000
   VALUE DEVPARM;                                                       26220000
   DOUBLE DEVPARM;                                             <<06730>>26225000
   OPTION PRIVILEGED, UNCALLABLE;                                       26230000
BEGIN                                                                   26235000
                                                               <<04201>>26240000
   << The STDLISTFAIL bit will be set by MORGUE when the     >><<04201>>26245000
   << FJOPEN of $STDLIST (from :JOB, i.e. virtual) fails. In >><<04201>>26250000
   << this case, we want make sure the file usecount (LDT(0))>><<04201>>26255000
   << gets set to zero, the LPDT shows as unowned, and that  >><<04201>>26260000
   << the ODD entry gets removed. However we DO NOT want to  >><<04201>>26265000
   << perform any disc deallocation. Before UCOP launches a  >><<04201>>26270000
   << job/session it will pre-allocate the devices for $STDx.>><<04201>>26275000
   << UCOP will NEVER allocate the disc space for the spooled>><<04201>>26280000
   << devices. FJOPEN will not perform any deallocation - it >><<04201>>26285000
   << knows that $STDLIST is a new file so upon a failure has>><<04201>>26290000
   << nothing to deallocate. So it now becomes MORGUE's      >><<04201>>26295000
   << responsibility to clean up after the FJOPEN failures.  >><<06730>>26300000
   << Therefore we will do everything EXCEPT deallocate disc >><<04201>>26305000
   << space.                                                 >><<04201>>26310000
                                                               <<07050>>26315000
<< Note:  The following EQUATE is a parameter to the  AWAKE >> <<07050>>26320000
<< procedure,  and  represents  a  PCB  event mask position >> <<07050>>26325000
<< shifted right four bits.  It is currently unavailable in >> <<07050>>26330000
<< any $INCLUDE file, which is why it is here!  If the  un- >> <<07050>>26335000
<< derlying  event  mask  (or the AWAKE interface) changes, >> <<07050>>26340000
<< this EQUATE will also have to change.                    >> <<07050>>26345000
                                                               <<07050>>26350000
   EQUATE                                                      <<07050>>26355000
                     JUNKWAIT   = %20;                         <<07050>>26360000
                                                               <<04201>>26365000
   DEFINE            << INPUT PARAMETER BREAKDOWN: >>                   26370000
                     ALLOCED     = NOT DEVPARM0.(5:1) #,       <<06730>>26375000
                     IOABORT     =     DEVPARM0.(4:1) #,       <<06730>>26380000
                     LABELLED    =     DEVPARM0.(3:1) #,       <<06730>>26385000
                     LDEV        =     DEVPARM1       #,       <<06730>>26390000
                     PRIMED      = NOT DEVPARM0.(7:1) #,       <<06730>>26395000
                     STDLISTFAIL =     DEVPARM0.(2:1) #,       <<06730>>26400000
                     WAIT        = NOT DEVPARM0.(6:1) #;       <<06730>>26405000
                                                               <<06730>>26410000
   EQUATE            DS'PSEUDO'TERM = 3;                       <<06730>>26415000
                                                               <<06730>>26420000
   INTEGER           SAVE'LDT'SIR,                             <<06730>>26425000
                     SAVE'XDD'SIR;                             <<06730>>26430000
   LOGICAL POINTER   XDD'HEAD,       << Req'd by XDD $INCL  >> <<06730>>26435000
                     XDD'SUBENTRY;   << This one too.       >> <<06730>>26440000
   DOUBLE POINTER    XDD'DSUBENTRY = XDD'SUBENTRY;             <<06730>>26445000
   DOUBLE ARRAY      DISKADDR(0:1) = Q;                                 26450000
   BYTE   ARRAY      DISKADDR'B(*) = DISKADDR;                 <<S8651>>26455000
   INTEGER           LDT'INDEX := 0,                           <<06730>>26460000
                     LDTX'INDEX := 0,                          <<06730>>26465000
                     LPDT'INDEX,                               <<06730>>26470000
                     ROOSTER'PARM;                             <<06730>>26475000
   LOGICAL           DEVPARM0 = DEVPARM,                       <<06730>>26480000
                     DEVPARM1 = DEVPARM0 + 1,                  <<06730>>26485000
                     FOUND'IT,                                 <<06730>>26490000
                     TRAILERPRINTED  := FALSE;                 <<06730>>26495000
   LOGICAL ARRAY                                               <<06730>>26500000
      LDT (0:SIZE'OF'LDT'ENTRY-1),                             <<06730>>26505000
      LDTX(0:SIZE'OF'LDTX'ENTRY-1),                            <<06730>>26510000
      XDD(*) = DB + 0;   << Required by XDD $INCLUDE file.  >> <<06730>>26515000
                                                               <<06730>>26520000
                                                               <<06730>>26525000
   SUBROUTINE DEF'MOVEFROMDSEG;                                <<06730>>26530000
                                                               <<06730>>26535000
   SUBROUTINE DEF'MOVETODSEG;                                  <<06730>>26540000
                                                                        26545000
                                                                        26550000
LOGICAL SUBROUTINE FIND'ENTRY (XDD'DST, XDD'SIR, REMOVE);      <<06730>>26555000
   VALUE   XDD'DST, XDD'SIR, REMOVE;                           <<06730>>26560000
   INTEGER XDD'DST, XDD'SIR;                                   <<06730>>26565000
   LOGICAL REMOVE;                                             <<06730>>26570000
                                                               <<06730>>26575000
BEGIN COMMENT --                                               <<06730>>26580000
  FIND'ENTRY searches the chain defined externally by XDD'HEAD <<06730>>26585000
for an appropriate subentry and returns its XDD  segment-rela- <<06730>>26590000
tive address.  If REMOVE is TRUE the subentry is also delinked <<06730>>26595000
from the chain and its space deallocated from the XDD. "Appro- <<06730>>26600000
priate" here means a non-spooled devicefile in the OPEN  state <<06730>>26605000
(ALLOCED = TRUE) or the READY state (ALLOCED = FALSE). Spooled <<06730>>26610000
devicefiles are ignored in here.                               <<06730>>26615000
;                                                              <<06730>>26620000
EXCHANGEDB (XDD'DST);                                          <<06730>>26625000
SAVE'XDD'SIR := GETSIR (XDD'SIR);                              <<06730>>26630000
@XDD'SUBENTRY := XDDH'FIRST'SUBENTRY;                          <<06730>>26635000
FOUND'IT := FALSE;                                             <<06730>>26640000
                                                               <<06730>>26645000
WHILE @XDD'SUBENTRY <> XDDS'END'OF'CHAIN AND NOT FOUND'IT DO   <<06730>>26650000
      BEGIN                                                    <<06730>>26655000
      IF XDDSD'DISC'LABEL = 0D THEN   << Not spooled        >> <<06730>>26660000
         IF ALLOCED AND XDDS'SPOOL'STATE = XDDS'OPEN           <<06730>>26665000
            OR XDDS'SPOOL'STATE = XDDS'READY                   <<06730>>26670000
            THEN FOUND'IT := TRUE;                             <<06730>>26675000
      IF NOT FOUND'IT THEN @XDD'SUBENTRY := XDDS'NEXT'SUBENTRY;<<06730>>26680000
      END;   << WHILE loop.                                 >> <<06730>>26685000
                                                               <<06730>>26690000
IF (FIND'ENTRY := @XDD'SUBENTRY) <> XDDS'END'OF'CHAIN          <<06730>>26695000
   AND REMOVE THEN                                             <<06730>>26700000
   BEGIN                                                       <<06730>>26705000
   TOS := @XDDH'FIRST'SUBENTRY;     << Can't fool SPL...    >> <<06730>>26710000
   DELINKENTRY (*, XDD'SUBENTRY);   <<   any other way.     >> <<06730>>26715000
   DEALLOCENTRY (XDD'SUBENTRY);                                <<06730>>26720000
   END;                                                        <<06730>>26725000
RELSIR (XDD'SIR, SAVE'XDD'SIR);                                <<06730>>26730000
EXCHANGEDB (STACK);                                            <<06730>>26735000
END;             << of FIND'ENTRY.                          >> <<06730>>26740000
                                                                        26745000
                                                                        26750000
   LPDT'INDEX := LDEV * LPDT'ENTRY'SIZE;                       <<06730>>26755000
   SAVE'LDT'SIR := GETSIR (LDT'SIR);                           <<06730>>26760000
   MOVEFROMDSEG (@LDT, LDT'DST, 0, SIZE'OF'LDT'ENTRY);         <<06730>>26765000
   MOVEFROMDSEG (@LDTX, LDT'DST, LOGICAL (LDTX'BASE) +         <<06730>>26770000
                 LDEV*SIZE'OF'LDTX'ENTRY, SIZE'OF'LDTX'ENTRY); <<06730>>26775000
   MOVEFROMDSEG (@LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,      <<06730>>26780000
                 SIZE'OF'LDT'ENTRY);                           <<06730>>26785000
   IF LDT'ACCESS'TYPE = LDT'DIRECT'ACCESS AND                  <<06730>>26790000
      NOT LPDT'NOT'PV'OR'SYS THEN                              <<06730>>26795000
      BEGIN   << System disc or private volume.             >> <<06730>>26800000
      LDT'FILE'USE'CNT := LDT'FILE'USE'CNT - 1;                <<06730>>26805000
      IF LDT'FILE'USE'CNT = 0 AND LDT'DOWN'PENDING THEN        <<06730>>26810000
         BEGIN    <<DOWN WAS PENDING: TAKE DOWN>>                       26815000
         LDT'DOWN'PENDING := FALSE;   << No longer pending. >> <<06730>>26820000
         LDT'AVAIL'TO'SYS := FALSE;                            <<06730>>26825000
         MOVETODSEG (LDT'DST, LDEV * SIZE'OF'LDT'ENTRY, @LDT,  <<06730>>26830000
                     SIZE'OF'LDT'ENTRY);                       <<06730>>26835000
         RELSIR (LDT'SIR, SAVE'LDT'SIR);                       <<06730>>26840000
                                                               <<03507>>26845000
         << Deallocate and delete disc free space data >>      <<03507>>26850000
         << segment, ignore errors.                    >>      <<03507>>26855000
                                                               <<03507>>26860000
         Deallocate'Dfs'Data'Seg (ldev);                       <<03507>>26865000
                                                               <<03507>>26870000
         Delete'Dfs'Data'Seg (Ldev);                           <<03507>>26875000
                                                               <<03507>>26880000
         GENMSG(1,250,%10000,LDEV,,,,,0);                      <<0U.EB>>26885000
         END;                                                           26890000
      END    <<DISC DEALLOC>>                                           26895000
   ELSE                                                                 26900000
      BEGIN    <<NON-SHARABLE DEVICE>>                                  26905000
      IF NOT ALLOCED THEN GOTO ELIM;                                    26910000
                                                                        26915000
      IF NOT LDT'CS'DEVICE AND NOT LPDT'VIRTUAL'DEVICE THEN    <<06730>>26920000
        IF PRIMED OR LDT'DEVICE'TYPE = LDT'TERMINAL THEN       <<06730>>26925000
          IF LDT'FILE'USE'CNT > 1 THEN                         <<06730>>26930000
             BEGIN   << Not the last FCLOSE to this device. >> <<06730>>26935000
             RELSIR (LDT'SIR, SAVE'LDT'SIR);                   <<06730>>26940000
             ATTACHIO (LDEV, 0, 0, 0, 3, 0, 0, 0, 7);          <<06730>>26945000
             SAVE'LDT'SIR := GETSIR (LDT'SIR);                 <<06730>>26950000
             END                                               <<06730>>26955000
          ELSE << file'use'cnt = 1 >>                                   26960000
            IF GET'DSDEVICE(LDEV) = DS'PSEUDO'TERM THEN        <<06730>>26965000
              BEGIN                                            <<06730>>26970000
              RELSIR (LDT'SIR, SAVE'LDT'SIR);                  <<06730>>26975000
              ATTACHIO (LDEV, 0, 0, 0, 3, 0, 1, 0, 1);         <<06730>>26980000
              SAVE'LDT'SIR := GETSIR (LDT'SIR);                <<06730>>26985000
              END                                              <<06730>>26990000
            ELSE << file'use'cnt = 1, not pseudo-terminal >>            26995000
              IF NOT LDTX'CIPER'PROTOCOL THEN                  <<06730>>27000000
                BEGIN                                          <<04843>>27005000
                RELSIR (LDT'SIR, SAVE'LDT'SIR);                <<06730>>27010000
                ATTACHIO (LDEV, 0, 0, 0, 3, 0, 0, 0, %17);     <<07229>>27015000
                SAVE'LDT'SIR := GETSIR (LDT'SIR);              <<06730>>27020000
                END;                                           <<04843>>27025000
                                                               <<04843>>27030000
<< If we took one of the three paths above  which  releases >> <<B8395>>27035000
<< the  LDT  SIR, another process may have modified the use >> <<B8395>>27040000
<< count.  Refresh the local copy now that we have the  SIR >> <<B8395>>27045000
<< again.                                                   >> <<B8395>>27050000
                                                               <<B8395>>27055000
      MOVEFROMDSEG (@LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,   <<B8395>>27060000
                    SIZE'OF'LDT'ENTRY);                        <<B8395>>27065000
      LDT'FILE'USE'CNT := LDT'FILE'USE'CNT - 1;                <<06730>>27070000
      IF INTEGER (LDT'FILE'USE'CNT) < 0 THEN                   <<07050>>27075000
         SUDDENDEATH (SD366);                                  <<07050>>27080000
      IF LDT'FILE'USE'CNT = 0 THEN                             <<06730>>27085000
         BEGIN    <<FINAL DEALLOC>>                                     27090000
  ELIM:                                                                 27095000
         LDT'MAIN'PIN := 0;                                    <<06730>>27100000
         IF NOT LPDT'VIRTUAL'DEVICE THEN                       <<06730>>27105000
            BEGIN  <<REAL DEVICE>>                                      27110000
                                                               <<04274>>27115000
            << If forms on a terminal, turn forms off.      >> <<04274>>27120000
                                                               <<04274>>27125000
            IF LDT'DEVICE'TYPE = LDT'TERMINAL THEN             <<06730>>27130000
               LDT'SPECIAL'FORMS := 0;                         <<06730>>27135000
                                                               <<04274>>27140000
            @XDD'HEAD := LDT'XDD'HEAD'INDEX * SIZE'OF'XDD'HEAD;<<06730>>27145000
            MOVETODSEG (LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,     <<06730>>27150000
                        @LDT, SIZE'OF'LDT'ENTRY);              <<06730>>27155000
            RELSIR (LDT'SIR, SAVE'LDT'SIR);                    <<06730>>27160000
                                                               <<06730>>27165000
<< Even though we've updated the LDT, we  can  continue  to >> <<06730>>27170000
<< read from our local copy.                                >> <<06730>>27175000
                                                               <<06730>>27180000
            IF IOABORT AND LDT'ACCESS'TYPE <> LDT'IO'CONCURRENT<<06730>>27185000
               AND LDT'ACCESS'TYPE <> LDT'DIRECT'ACCESS        <<06730>>27190000
               THEN ABORTIO(-LDEV);                                     27195000
            IF LDT'ACCESS'TYPE <> LDT'SERIAL'IN                <<06730>>27200000
               AND (@XDD'SUBENTRY := FIND'ENTRY (ODD'DST,      <<06730>>27205000
                    ODD'SIR, FALSE)) <> XDDS'END'OF'CHAIN THEN <<06730>>27210000
               BEGIN    <<ODD ENTRY EXISTS: [TRAILER &] REMOVE>>        27215000
               IF PRIMED THEN                                           27220000
                  BEGIN                                        <<06730>>27225000
                  IF LDTX'CIPER'PROTOCOL THEN                  <<06730>>27230000
                                                               <<06730>>27235000
  COMMENT -- This is the second time the CIPER protocol forces <<06730>>27240000
us to stand on our heads.  The first time was a few lines  ago <<06730>>27245000
where the final (use count -> 0) ATTACHIO FCLOSE was postponed <<06730>>27250000
for CIPER devices.  Here we do a special case (that is, CIPER) <<06730>>27255000
buffer flush (function 186, Return Job Report  with  P1  =  0, <<06730>>27260000
flush  all  buffers to the device), then come out to print any <<06730>>27265000
required trailer (any eligible device, not just  CIPER),  then <<06730>>27270000
back  into CIPER to send it the End of Job (function 145), and <<06730>>27275000
finally the long-neglected final ATTACHIO FCLOSE.  This  whole <<06730>>27280000
area of DEALLOCATE could stand some rethinking.                <<06730>>27285000
;                                                              <<06730>>27290000
                     ATTACHIO (LDEV,0,0,0,186,0,0,0,1);        <<06730>>27295000
                  TRAILERPRINTED := TRAILER (XDD'SUBENTRY,     <<06730>>27300000
                     LDEV, LDT'DEVICE'TYPE, LDT'RECORD'WIDTH); <<06730>>27305000
                  IF LDTX'CIPER'PROTOCOL THEN                  <<06730>>27310000
                     BEGIN   << End of Job, final FCLOSE.   >> <<06730>>27315000
                     ATTACHIO (LDEV,0,0,0,145,0,0,0,1);        <<06730>>27320000
                     ATTACHIO (LDEV,0,0,0,  3,0,0,0,1);        <<06730>>27325000
                     END;                                      <<06730>>27330000
                  END;   << IF PRIMED...                    >> <<06730>>27335000
               TOS := @XDD'SUBENTRY;                           <<06730>>27340000
               TOS.(0:1) := 1;                                          27345000
               SREMOVEXDD (*);                                          27350000
               END;                                                     27355000
            IF LDT'ACCESS'TYPE <> LDT'SERIAL'OUT THEN          <<06730>>27360000
               << FIND ENTRY AND REMOVE, IF THERE IS 1 >>               27365000
               FIND'ENTRY (IDD'DST, IDD'SIR, TRUE);            <<06730>>27370000
                                                               <<03607>>27375000
<< The call to FREEDEVICE must precede the release  of  any >> <<03607>>27380000
<< serial disc extra data segment.  FREEDEVICE makes an AT- >> <<03607>>27385000
<< TACHIO Device Close call which is ignored by the  serial >> <<03607>>27390000
<< disc code if the data segment has been released. But the >> <<03607>>27395000
<< Device Close call is sometimes needed to insure that the >> <<03607>>27400000
<< serial disc is logically (and for LINUS physically) dis- >> <<03607>>27405000
<< mounted.                                                 >> <<03607>>27410000
                                                               <<03607>>27415000
            FREEDEVICE (LDEV, WAIT LAND TRAILERPRINTED,        <<TL.02>>27420000
                        LABELLED);                             <<TL.02>>27425000
            IF LDT'ACCESS'TYPE = LDT'DIRECT'ACCESS AND         <<06730>>27430000
               LPDT'NOT'PV'OR'SYS AND NOT LABELLED THEN        <<06730>>27435000
               FORS'XDS'DEALLOC (LDEV);                        <<06730>>27440000
            END    << Real device.                          >>          27445000
         ELSE                                                           27450000
            BEGIN  <<VIRTUAL DEVICE>>                                   27455000
            @XDD'SUBENTRY := LPDT'XDD'SUBENTRY'PTR;            <<06730>>27460000
            IF LPDT'VDEV'DIRECTION = LPDT'VDEV'INPUT THEN      <<06730>>27465000
               BEGIN                                           <<06730>>27470000
               SREMOVEXDD (XDD'SUBENTRY);                      <<06730>>27475000
               MOVETODSEG (LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,  <<06730>>27480000
                           @LDT, SIZE'OF'LDT'ENTRY);           <<06730>>27485000
               RELSIR (LDT'SIR, SAVE'LDT'SIR);                 <<06730>>27490000
               END                                             <<06730>>27495000
            ELSE                                                        27500000
               BEGIN    << NEW SPOOLFILE >>                             27505000
               EXCHANGEDB (ODD'DST);                           <<06730>>27510000
               SAVE'XDD'SIR := GETSIR (ODD'SIR);               <<06730>>27515000
               @XDD'HEAD := XDDS'HEAD'INDEX * XDD0'HEAD'LENGTH;<<06730>>27520000
               TOS := @XDDH'FIRST'SUBENTRY;  << To fool...  >> <<06730>>27525000
               DELINKENTRY (*, XDD'SUBENTRY);  << SPL.      >> <<06730>>27530000
               IF PRIMED THEN                                           27535000
                  BEGIN                                                 27540000
                  SLINKXDD (XDDS'HEAD'INDEX, XDD'SUBENTRY);    <<06730>>27545000
                  XDDS'SPOOL'STATE := XDDS'READY;              <<06730>>27550000
                  XDDSD'READY'TIME := DOUBLETIME;              <<06730>>27555000
                  IF XDDS'CLASS THEN                           <<06730>>27560000
                     ROOSTER'PARM := -XDDS'DEVICE              <<06730>>27565000
                  ELSE ROOSTER'PARM := XDDS'DEVICE;            <<06730>>27570000
                  END                                                   27575000
               ELSE                                                     27580000
                  BEGIN                                                 27585000
                  TOS := LUN (XDDS'SPOOFLE'VT'INDEX, 0);       <<S8651>>27590000
                  DISKADDR := XDDSD'DISC'LABEL;                <<S8651>>27595000
                  DISKADDR'B := TOS;                           <<S8651>>27600000
                  DEALLOCENTRY (XDD'SUBENTRY);                 <<06730>>27605000
                  END;                                                  27610000
               RELSIR (ODD'SIR, SAVE'XDD'SIR);                 <<06730>>27615000
               EXCHANGEDB (STACK);                             <<06730>>27620000
               MOVETODSEG (LDT'DST, LDEV * SIZE'OF'LDT'ENTRY,  <<06730>>27625000
                           @LDT, SIZE'OF'LDT'ENTRY);           <<06730>>27630000
               RELSIR (LDT'SIR, SAVE'LDT'SIR);                 <<06730>>27635000
               IF PRIMED THEN                                           27640000
                  SROOSTER (ROOSTER'PARM)                      <<06730>>27645000
               ELSE                                                     27650000
                  BEGIN                                                 27655000
                  IF NOT STDLISTFAIL  THEN                     <<04201>>27660000
                      DISKDEALLOC(0,0,%201,DISKADDR);          <<04201>>27665000
                  END;                                                  27670000
               END;   << New spoolfile.                     >> <<07050>>27675000
            DISABLE;                                           <<06730>>27680000
            LPDT'DEV'OWN'STATE := LPDT'NOT'OWNED;              <<06730>>27685000
                                                               <<07050>>27690000
  COMMENT -- We communicate with UCOP  through  some  bits  in <<07050>>27695000
SYSGLOB.  We set a bit saying we are freeing up a device. Then <<07050>>27700000
we see if UCOP is waiting for a device to become free (another <<07050>>27705000
bit).  If so we AWAKEn UCOP, because we have just freed one it <<07050>>27710000
may be able to use.  We also clear the UCOP wait bit.          <<07050>>27715000
;                                                              <<07050>>27720000
            SYSDEVAVAIL := TRUE;                               <<07050>>27725000
            TOS := SYSWAITFORDEV;                              <<07050>>27730000
            SYSWAITFORDEV := FALSE;                            <<07050>>27735000
            ENABLE;                                            <<07050>>27740000
            IF TOS THEN AWAKE (SYSUCOPPCB, JUNKWAIT, 0);       <<07050>>27745000
            END;   << Virtual device.                       >> <<07050>>27750000
         END     << Final devicefile deallocation.          >> <<06730>>27755000
      ELSE                                                     <<06730>>27760000
         BEGIN   << Not final dealloc., release resources.  >> <<06730>>27765000
         MOVETODSEG (LDT'DST, LDEV * SIZE'OF'LDT'ENTRY, @LDT,  <<06730>>27770000
                     SIZE'OF'LDT'ENTRY);                       <<06730>>27775000
         RELSIR (LDT'SIR, SAVE'LDT'SIR);                       <<06730>>27780000
         END;                                                  <<06730>>27785000
      END;    <<NON-SHARABLE DEVICE TREATMENT>>                         27790000
   END;    <<DEALLOCATE>>                                               27795000
$PAGE "   ***   Global symbol table   ***"                     <<06730>>27800000
$PAGE                                                          <<06730>>27805000
$CONTROL SEGMENT=MAIN                                                   27810000
END.   << of module ALLOCATE.                               >> <<06730>>27815000
