$CONTROL MAP,CODE,USLINIT                                               00005000
$CONTROL DEFINE                                                <<07063>>00010000
<<SPOOLCOMS - MODULE 80>>                                      <<01549>>00015000
<< HP32002C MPE SOURCE C.00.00 >>                                       00020000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00025000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00030000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00035000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00040000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00045000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00050000
$THIRTY                                                                 00055000
$CONTROL PRIVILEGED                                                     00060000
$CONTROL MAIN=SPOOLCOMS                                        <<04833>>00065000
$CONTROL SEGMENT=SPOOLCOMS1                                             00070000
<< MPE 3000/30 SPOOLING FACILITY >>                                     00075000
BEGIN                                                                   00080000
$PAGE "***  GENERAL/GLOBAL EQUIVALENCES   ***"                          00085000
EQUATE                                                         <<07438>>00090000
           STACK             = 0                  ;            <<07438>>00095000
                                                               <<07438>>00100000
DEFINE                                                                  00105000
           A                 = ABSOLUTE          #,                     00110000
           ENAPROC           = ASSEMBLE(PSEB)    #,                     00115000
           DISAPROC          = ASSEMBLE(PSDB)    #,                     00120000
           DISABLE           = ASSEMBLE(SED 0)   #,                     00125000
           ENABLE            = ASSEMBLE(SED 1)   #;                     00130000
INTEGER                                                                 00135000
           DB0               = DB+0  ,                                  00140000
           DB1               = DB+1  ,                                  00145000
           DB2               = DB+2  ,                                  00150000
           DB3               = DB+3  ,                                  00155000
           DB4               = DB+4  ,                                  00160000
           DB5               = DB+5  ,                                  00165000
           DB6               = DB+6  ,                                  00170000
           DB7               = DB+7  ,                                  00175000
           DB8               = DB+8  ,                                  00180000
           DB9               = DB+9  ,                                  00185000
           DB10              = DB+10 ,                                  00190000
           DB11              = DB+11 ,                                  00195000
           S0                = S-0   ,                                  00200000
           S1                = S-1    ,                        <<00170>>00205000
           S2                = S-2    ,                        <<00170>>00210000
           X                 = X     ,                                  00215000
           XREG              = X     ;                                  00220000
LOGICAL                                                                 00225000
           LDB3              = DB+3  ;                                  00230000
INTEGER POINTER                                                         00235000
           PDB0              = DB+0  ,                                  00240000
           PDB1              = DB+1  ,                                  00245000
           PDB2              = DB+2  ,                                  00250000
           PDB3              = DB+3  ,                                  00255000
           PDB4              = DB+4  ,                                  00260000
           PS0               = S-0   ,                                  00265000
           PS1               = S-1   ;                                  00270000
BYTE POINTER                                                            00275000
           BPS0              = S-0   ;                                  00280000
INTEGER ARRAY                                                           00285000
           ARRDB0(*)         = DB+0  ,                                  00290000
           ARRDB1(*)         = DB+1  ,                                  00295000
           ARRDB12(*)        = DB+12 ,                                  00300000
           ARRQ0(*)          = Q-0   ,                                  00305000
           ARRS0(*)          = S-0   ;                                  00310000
BYTE ARRAY                                                              00315000
           BARRS4(*)         = S-4   ;                                  00320000
DOUBLE POINTER                                                          00325000
           DPS0              = S-0   ;                                  00330000
$PAGE "***   SPOOLING CONSTANTS   ***"                                  00335000
EQUATE                                                                  00340000
           BSIZE             = 512   ,                                  00345000
           RSIZE             = 128   ,                                  00350000
           MAXRSIZE          = 255   ,                                  00355000
           SECTOR'SIZE       = 128   ,                         <<06744>>00360000
           XDDHSIZE          = 4     ,                                  00365000
           XDDSIZE           = 30    ,                                  00370000
           IDDHSIZE          = XDDHSIZE  ,                              00375000
           IDDSIZE           = XDDSIZE   ,                              00380000
           ODDHSIZE          = XDDHSIZE  ,                              00385000
           ODDSIZE           = XDDSIZE   ,                              00390000
           JMATSIZE          = 26    ,                                  00395000
           JMATERRSIZE       = JMATSIZE -3 ,                            00400000
<< MESSAGE CATALOG NUMBERS FOR SPOOLER/CI MESSAGES >>                   00405000
           NORMALSTOP        = 237   ,                                  00410000
           NONEXISTENTDEV    = 222   ,                                  00415000
           NOTACCEPTING      = 224   ,                                  00420000
           SPOOFLEIOERR      = 225   , <<80>>                           00425000
           NOSUCHSTACK       = 81    ,                                  00430000
           NOSTREAMING       = 82    ,                                  00435000
           FILENOTASCII      = 83    ,                                  00440000
           CANNOTSINIT       = SPOOFLEIOERR ;                           00445000
<< COMMAND INTERPRETER ERROR MESSAGE EQUATES>>                 <<U.RAO>>00450000
EQUATE                                                         <<U.RAO>>00455000
   ACCTEXPECTALPHA  =  550,   <<LEADING CHAR MUST BE ALPHA>>   <<U.RAO>>00460000
   ACCTNAMEMISSING  =  551,   <<EXPECTED ACCOUNT NAME>>        <<U.RAO>>00465000
   ACCTNAMETOOLONG  =  552,   <<ACCT NAME > 8 CHAR>>           <<U.RAO>>00470000
   ACCTEXPECTNAMENOTAT=553,   <<EXPECTED NAME, FOUND "@">>     <<U.RAO>>00475000
   USEREXPECTALPHA  =  590,                                    <<U.RAO>>00480000
   USERNAMEMISSING  =  591,                                    <<U.RAO>>00485000
   USERNAMETOOLONG  =  592,                                    <<U.RAO>>00490000
   USEREXPECTNAMENOTAT=593,                                    <<U.RAO>>00495000
   SHOWNODST        = 1127,   <<OUT OF DST'S>>                 <<00548>>00500000
   SHOWNOVDS        = 1128,   <<OUT OF VIRTUAL MEM FOR DST>>   <<00548>>00505000
   SHOWNOSPACE      = 1129,   <<OUT OF SPACE IN DST>>          <<00548>>00510000
   SHOWSYSERR       = 1130,   <<UNKNOW ERROR USING DST>>       <<00548>>00515000
   SHOWJOBOPNERR    =  1495,   <<CAN'T OPEN LISTFILE>>         <<01446>>00520000
   SHJBEXPARMLST    =  1496,   <<IGNRD PARMS PAST LISTFILE>>   <<01446>>00525000
   SHOWJOBCLSERR    =  1497,   <<CAN'T CLOSE LISTFILE>>        <<01446>>00530000
   SHOWJSTATSIGNRD  = 1500,   <<STATUS REQUEST IGNORED>>       <<U.RAO>>00535000
   SHOWJXTRANPARMS  = 1501,   <<EXTRA PARMS IGNORED>>          <<U.RAO>>00540000
   SHOWJXPCTJOB     = 1502,   <<EXPECTED JOB ID>>              <<U.RAO>>00545000
   SHOWJXPCTATS     = 1503,   <<EXPECTED "@S">>                <<U.RAO>>00550000
   SHOWJXPCTATJ     = 1504,   <<EXPECTED "@J">>                <<U.RAO>>00555000
   SHOWJUNKATX      = 1505,   <<EXPECTED EITHER "@S" OR "@J">> <<U.RAO>>00560000
   SHOWJJNAME2LONG  = 1506,   <<JOB NAME > 8 CHARACTERS LONG>> <<U.RAO>>00565000
   SHOWJJNXPCTALPH  = 1507,   <<EXPECTED ALPHA LEADING CHAR>>  <<U.RAO>>00570000
   SHOWJXPCTJN      = 1508,   <<SPECIALS EMBEDDED IN JOB NAME>><<U.RAO>>00575000
   SHOWJXPCTJSNUM   = 1509,   <<EXPECTED EITHER J OR S>>       <<U.RAO>>00580000
   SHOWJXPLCTJ2MP   = 1510,   <<EXTRA PARMS IGNORED>>          <<U.RAO>>00585000
   SHOWJUNKKEY      = 1511,   <<UNKNOWN KEYWORD>>              <<U.RAO>>00590000
   SHOWJ2MERRORS    = 1512,   <<TOO MANY ERRORS, PARSING STOPPE<<U.RAO>>00595000
   SHOWJFSERR       = 1513,   <<SCRATCH FILE ERROR>>           <<U.RAO>>00600000
   SHOWJREDNDSTATE  = 1514,   <<INCONSISTENT SPEC OF JOB STATE><<U.RAO>>00605000
   SHOWJNDINAP      = 1515,   <<ONLY WITH WAIT STATE>>         <<U.RAO>>00610000
   SHOWJUNKDEFR     = 1516,   <<UNKNOWN DEFER STATE>>          <<U.RAO>>00615000
   SHOWJXPCTUN      = 1517,   <<EMBEDDED SPECIALS NOT ALLOWED>><<U.RAO>>00620000
   SHOWJXPCTPERIOD  = 1518,   <<USER.ACCT>>                    <<U.RAO>>00625000
   SHOWJXPCTAN      = 1519,   <<EMBEDDED SPECIALS NOT ALLOWED>><<U.RAO>>00630000
   SHOWJREDUNDJOB   = 1520,   <<JOB PARM REDUNDANTLY SPECIFIED><<U.RAO>>00635000
   SHOWJXPCTJOBEQ   = 1521,   <<EXPECTED = SIGN AFTER "JOB">>  <<U.RAO>>00640000
   SHOWFXPCTODEVFL  = 1530,   <<ONLY OUTFILES WITH SHOWOUT>>   <<U.RAO>>00645000
   SHOWFXPCTIDEVFL  = 1531,   <<ONLY INFILES WITH SHOWIN>>     <<U.RAO>>00650000
   SHOWFINVLDDFID   = 1532,   <<INVALID DEVICEFILE ID>>        <<U.RAO>>00655000
   SHOWFXTRAIGNORD  = 1533,   <<EXTRA PARAMETERS INAPPROPRIATE><<U.RAO>>00660000
   SHOWFUNKKEY      = 1534,   <<UNKNOWN KEYWORD>>              <<U.RAO>>00665000
   SHOWFSTATSIGNRD  = 1535,   <<STATUS PARM IGNORED>>          <<U.RAO>>00670000
   SHOWFXTRANPARMS  = 1536,   <<UNIDENTIFIABLE PARAMETERS>>    <<U.RAO>>00675000
   SHOWFFSERR       = 1537,   <<SCRATCH FILE FILESYS ERROR>>   <<U.RAO>>00680000
   SHOWF2MERRORS    = 1538,   <<TOO MANY ERRORS IN PARSE>>     <<U.RAO>>00685000
   SHOWFREDNDSTATE  = 1539,   <<STATE INCONSISTENTLY SPECIFIED><<U.RAO>>00690000
   SHOWFINNDINAP    = 1540,   <<INPUT FILES CANNOT BE DEFERRED><<U.RAO>>00695000
   SHOWFOUTNDINAP   = 1541,   <<APPROPRIATE ONLY FOR "READY" FI<<U.RAO>>00700000
   SHOWFUNKDEFR     = 1542,   <<EXPECTED "N" OR "D">>          <<U.RAO>>00705000
   SHOWFXPCTJOBEQ   = 1543,   <<EXPECTED "JOB=">>              <<U.RAO>>00710000
   SHOWFXPCTJOB     = 1544,   <<INVALID JOB NAME SYNTAX>>      <<U.RAO>>00715000
   SHOWFXPCTATS     = 1545,   <<EXPECTED @S OR @S'>>           <<U.RAO>>00720000
   SHOWFXPCTATJ     = 1546,   <<EXPECTED @J OR @J'>>           <<U.RAO>>00725000
   SHOWFUNKATX      = 1547,   <<UNKNOWN JOB TYPE>>             <<U.RAO>>00730000
   SHOWFXPCTSNUM    = 1548,   <<INVALID SESSION NUMBER>>       <<U.RAO>>00735000
   SHOWFXPCTJNUM    = 1549,   <<INVALID JOB NUMBER>>           <<U.RAO>>00740000
   SHOWFXPCTJSNUM   = 1550,   <<INVALID JOB ID>>               <<U.RAO>>00745000
   SHOWFREDUNDJOB   = 1551,   <<REDUNDANTLY SPECIFIED>>        <<U.RAO>>00750000
   SHOWFXPCTDEV     = 1552,   <<EXPECTED DEVICE>>              <<U.RAO>>00755000
   SHOWFINVLDDEVSP  = 1553,   <<INVALID DEVICE SPECIFICATION>> <<U.RAO>>00760000
   SHOWFINPTDEVCLS  = 1554,   <<DEV CLASS INAPPROPRIATE FOR INP<<U.RAO>>00765000
   SHOWFDACCESSDEV  = 1555,   <<DIRECT ACCESS INAPPROPRIATE>>  <<U.RAO>>00770000
   SHOWFRDNTDEV     = 1556,   <<REDUNDANT>>                    <<U.RAO>>00775000
   SHOWDV2MP        = 1580,  <<TOO MANY PARAMETERS TO SHOWDEV>><<U.RAO>>00780000
   SHOWDVNOSUCHLDN  = 1581,  <<LDN CAN'T BE FOUND ON SYSTEM>>  <<U.RAO>>00785000
   SHOWDVINVLDCLAS  = 1582,  <<CLASS NAME > 8 CHARACTERS>>     <<U.RAO>>00790000
   SHOWDVNOSUCHCLS  = 1583,  <<CAN'T FIND DEVICE CLASS ON SYS>><<U.RAO>>00795000
   SHOWFDSDEVICE    = 1584,  <<DS DEVICE INAPPROPRIATE>>       <<01906>>00800000
   STRMNOTENABLED   =   82,  <<STREAM DISABLED>>               <<U.RAO>>00805000
   STRMNOSYSDEF     = 1590,  <<SYS DEF FILE NOT ALLOWED>>      <<U.RAO>>00810000
   STRMINVLDCOLON   = 1591,  <<BAD PSEUDOCOLON>>               <<U.RAO>>00815000
   STRMFILEOPENERR  = 1596, <<CAN'T OPEN STREAM FILE>>         <<00534>>00820000
   STRMXPCTSEMI     = 6304,  << No semicolon before keywords >><<S8948>>00825000
   <<GENERAL CI MESSAGES>>                                     <<U.RAO>>00830000
   CIGENERALMSGSET  =  7,                                      <<U.RAO>>00835000
                                                               <<U.RAO>>00840000
   SHOWFHEADER      =  14,                                     <<U.RAO>>00845000
   SHOWFFILECNTDSP  =  15,                                     <<U.RAO>>00850000
   SHOWFFILECNT     =  16,                                     <<U.RAO>>00855000
   SHOWFACTIVECNT   =  17,                                     <<U.RAO>>00860000
   SHOWFREADYCNT    =  18,                                     <<U.RAO>>00865000
   SHOWFOPENEDCNT   =  19,                                     <<U.RAO>>00870000
   SHOWFLOCKEDCNT   =  20,                                     <<U.RAO>>00875000
   SHOWFDEFCNT      =  21,                                     <<U.RAO>>00880000
   SHOWFSPOOFLECNT  =  22,                                     <<U.RAO>>00885000
   SHOWFNOSUCHFLS   =  23,                                     <<U.RAO>>00890000
   SHOWFOUTFENCE    =  24,                                     <<00874>>00895000
   SHOWFDEVFENCE    =  27;                                     <<00874>>00900000
$PAGE "CONSOLE ERROR MESSAGES"                                          00905000
<< Console error messages added as part of this fix.        >> <<04833>>00910000
                                                                        00915000
EQUATE                                                                  00920000
   OPCOMMNOTALLOW        = 3000, <<NO USER ACCESS TO OPRAT CMND>>       00925000
   EXPLDEVBAD            = 3001, <<EXPECTED LDEV # BAD>>                00930000
   LDEVNOTCONFIG         = 3002, <<LDEV NOT IN THIS CONFIG.>>           00935000
   HEADONREQ1P           = 3003, <<HEADON HAS EXACTLY 1 PARM>>          00940000
   HEADOFFREQ1P          = 3004, <<HEADOFF HAS EXACTLY ONE PARM>>       00945000
   LDEVNOTCRPRPNCH       = 3005, <<EXPCTD CARD RDR, PRNTR, PNCH>>       00950000
   USERNOACC2DEV         = 3006, <<USER HAS NO ACCESS TO DEVICE>>       00955000
   LDEVNOTREAL           = 3007, <<LOGICAL DEVICE IS NOT REAL>>         00960000
   GIVEREQ1P             = 3008, <<GIVE REQUIRES EXACTLY 1 PARM>>       00965000
   TAKEREQ1P             = 3009, <<TAKE REQUIRES EXACTLY 1 PARM>>       00970000
   LDEVINBYF             = 3010, <<DEVICE IN USE BY SYSTEM,>>           00975000
                                 <<  MUST BE DOWN              >>       00980000
   LDEVALINBYDIAG        = 3011, <<LDEV ALRDY IN USE BY DIAG>>          00985000
   UPREQ1P               = 3012, <<UP REQUIRES EXACTLY 1 PARM>>         00990000
   DOWNREQ1P             = 3013, <<DOWN REQUIRES EXACTLY 1 PARM>>       00995000
   LDEVINBYDIAG          = 3014, <<DEVICE IN USE BY DIAGNOSTICS>>       01000000
   LDEVALINBYF           = 3015, <<LDEV ALREADY IN USE BY SYS>>         01005000
   LDEVALDOWN            = 3016, <<DEVICE ALREADY DOWN>>                01010000
   LDEVALDOWNP           = 3017, <<LDEV ALRDY HAS DOWN PENDING>>        01015000
   LDEVINUSEDOWNP        = 3018, <<DEVICE IN USE, DOWN PENDING>>        01020000
   RECALLHEADER          = 3019, <<FOLLOWING REPLIES PENDING:>>         01025000
   WELCREADERR           =  901, <<CIERR-READ ERROR IN WELCM>> <<04833>>01030000
   NOREPLYPENDING        = 3020, <<NO REPLIES PENDING>>                 01035000
   ASSBYOTHERS           = 3021, <<LDEV ALRDY ASSOC BY OTHERS>>         01040000
   LDEVNOTINDIAG         = 3022, <<DEVICE NOT IN DIAGNOSTICS>>          01045000
   OUTFENCEREQ1P         = 3023, <<OUTFENCE REQUIRES 1 PARM>>           01050000
   EXPPRIOR1TO14         = 3024, <<OUTFENCE PRI EXPCT 1-14>>            01055000
   EXPPRIORGT14          = 3025, <<PRIORITY > 14, 14 USED>>             01060000
   EXPPRIORLT1           = 3026, <<PRIORITY <  1, 1  USED>>             01065000
   ABORTIOREQ1P          = 3027, <<ABORTIO REQUIRES 1 PARM>>            01070000
   NOIOQED4DEV           = 3028, <<NO I/O TO ABORT FOR DEVICE>>         01075000
   ACCEPTREQ2PARM        = 3029, <<ACCEPT HAS AT MOST TWO PARMS>>       01080000
   REFUSEREQ2PARM        = 3030, <<REFUSE HAS AT MOST TWO PARMS>>       01085000
   ACCEPTREQ1P           = 3031, <<ACCEPT MUST HAVE < =  1 PARM.>>      01090000
   REFUSEREQ1P           = 3032, <<ACCPET MUST HAVE < =  1 PARAM.>>     01095000
   COMMAAFTERDJ          = 3033, <<"," EXPCT AFTER DATA OR JOBS>>       01100000
   FIRSTMUSTBEDJ         = 3034, <<EXPECTED 'DATA' OR 'JOBS'>>          01105000
   LDEVNOTDJ             = 3035, <<LDEV NOT DATA/JOB ACCEPTING>>        01110000
   LDEVHASNODEFOUT       = 3036, <<LDEV HAS NO DEFLT OUTDEV>>           01115000
   WELMSGBUSY            = 3037, <<WELCOME DST'S BUSY>>                 01120000
   BREAKJOBREQ1P         = 3038, <<BREAKJOB HAS EXACTLY 1 PARM>>        01125000
   RESUMEJOBREQ1P        = 3039, <<RESUMEJOB HAS EXACTLY 1 PARM>>       01130000
   PARMNOTJOBID          = 3040, <<EXPECTED JOB ID (#JNNN)>>            01135000
   BADJOBNUM             = 3041, <<MUST BE POSITIVE INTEGER > 1>>       01140000
   NOSUCHJOB             = 3042, <<SPECIFIED JOB DOES NOT EXIST>>       01145000
   JOBNOTACTIVE          = 3043, <<BREAKJOB REQUIRES EXEC JOB>>         01150000
   JOBNOTSUSPENDED       = 3044, <<RESUMEJOB REQUIRES SUSP JOB>>        01155000
   SUSPENDJOBOWN         = 3045, <<SUSP JOB NNN OWNS LDEV MMM>>         01160000
   JOBINTERM             = 3046, <<RESUMING/SUSP JOB TERMNTNG>>         01165000
   NOTUSERSJOB           = 3047, <<USER RES/SUSP OTHER'S JOB>>          01170000
   REPLYREQ2P            = 3048, <<REPLY HAS AT LEAST 2 PARMS>>         01175000
   REPLYTOOMANYP         = 3049, <<REPLY HAS TOO MANY PARMS>>           01180000
   INVALIDPIN            = 3050, <<INVALID PIN GIVEN IN REPLY>>         01185000
   NOREQ4PIN             = 3051, <<NO REPLY OUTSTANDING FOR PIN>>       01190000
   REPLYEXPYN'NUM        = 3052, <<REPLY EXPECTED YES/NO OR #>>         01195000
   REPLYEXPYN            = 3053, <<REPLY EXPECTED Y/N>>                 01200000
   REPLYEXPNUMBER        = 3054, <<REPLY EXPECTED NUMBER>>              01205000
   ASSREQ1P              = 3055, <<ASSOCIATE HAS EXACTLY 1 PARM>>       01210000
   DISASSREQ1P           = 3056, <<DISASSOC HAS EXACTLY 1 PARM>>        01215000
   USERHASDEVASS         = 3057, <<USER ALREADY ASSOCIATED LDEV>>       01220000
   USERNOTASS2DEV        = 3058, <<USER CAN'T DISASSOC LDEV NOT>>       01225000
                                 <<  ASSOC WITH HIM            >>       01230000
   USERCANTASSDEV        = 3059, <<USER NOT ALLWD TO ASSOC LDEV>>       01235000
   REPLYEXP2PARM         = 3060, <<REPLY EXPECTED 2 PARMS ONLY>>        01240000
   STRINGTOOLONG         = 3061, <<REPLY STRING TOO LONG>>              01245000
   JOBFENCEREQ1P         = 3062, <<JOBFENCE REQ EXACTLY 1 PARM>>        01250000
   EXP0TO14              = 3063, <<JOBPRI MUST BE <0, >14>>             01255000
   EXPPRIORLT0           = 3064, <<JOBFENCE <0, ZERO USED>>             01260000
   EXPCOMMABREPLYP       = 3065, <<EXPCTD "," BETW REPLY PARMS>>        01265000
   STREAMSREQ1P          = 3066, <<STREAMS EXPCT EXACTLY 1 PARM>>       01270000
   CANTBETERM            = 3067, <<STREAMS DEV CAN'T BE TERM>>          01275000
   DEVNOTDJ              = 3068, <<STREAMS DEV NOT DATA/JOB ACC>>       01280000
   CONSOLEREQ1P          = 3069, <<CONSOLE REQ EXACTLY 1 PARM>>         01285000
   DEVNOTJOB             = 3070, <<CONSOLE DEV NOT JOB ACC>>            01290000
   EXP1OFSORJLIMIT       = 3071, <<EXPECTED JOB OR SESS LIMIT>>         01295000
   LIMITHAS2PARM         = 3072, <<LIMIT HAS AT MOST 2 PARMS>>          01300000
   EXPCOMMASJ            = 3073, <<LIMIT NEEDS "," BETW PARMS>>         01305000
   SLIMITBAD             = 3074, <<SESSION LIMIT BAD>>                  01310000
   JLIMITBAD             = 3075, <<JOB LIMIT BAD>>                      01315000
   EXPJNUMORJNAME        = 3076, <<EXPECTED JOBNUM OR JOBNAME>>         01320000
   DEVNOTOUTPUT          = 3077, <<ALTJOB OUTDEV MUST BE OUTDEV>>       01325000
   JOBNUMNOOTHERP        = 3078, <<JOBNUM HAS NO OTHER PARMS>>          01330000
   EXPJORSNUM            = 3079, <<EXPECTED #Jnnn OR #Snnn>>            01335000
   EXPUANDANAME          = 3080, <<EXPECTED USERNAME & ACCTNAME>>       01340000
   UORANAMEMAX8          = 3081, <<USER AND ACCT NAME > 8 CHARS>>       01345000
   PERIODEXP             = 3082, <<NO "." BETW USER/ACCT NAMES>>        01350000
   JOBBEINTRO            = 3083, <<CAN'T ABRT JOB BEING INTRO'D>>       01355000
   EXPACCTNAME           = 3084, <<EXPECTED [JOBNAME,]USER.NAME>>       01360000
   UORANAMEZERO          = 3085, <<USER/ACCT CAN'T BE 0 LENGTH>>        01365000
   EXP1OFINOUT           = 3086, <<ALTJOB KEYS NOT INPRI/OUTDEV>>       01370000
   EXPSEMICOLON          = 3087, <<NEED ";" BEFORE KEYS>>               01375000
   EXPEQUALS             = 3088, <<NEED " = " AFTER KEY>>               01380000
   EXPJAND1PARM          = 3089, <<ALTJOB REQ JOB + > =  1 KEY>>        01385000
   NOSUCHDEV             = 3090, <<NO SUCH DEVICE OR CLASS>>            01390000
   MUSTWAITORINTRO       = 3091, <<ALTJOB REQ WAIT/INTRO JOB>>          01395000
   CANTBESYSFILE         = 3092, <<(DIS)ALLOW FILE <> "$" FILE>>        01400000
   MUSTBEASNOCTL         = 3093, <<FILE = MUST BE ASCII/NOCCTL>>        01405000
   EXP1OFUSERFILE        = 3094, <<EXPECTED FILE =  OR>>                01410000
                                 <<  USER.ACCT;COMMANDS = >>            01415000
   EXPUSERNAME           = 3095, <<EXPECTED USERNAME>>                  01420000
   COMMANDSEPBYCOMMA     = 3096, <<COMMANDS ARE SEPRAT BY ",">>         01425000
   EXPCOMMANDS           = 3097, <<EXPECTED COMMANDS = >>               01430000
   NOSUCHCOMMAND         = 3098, <<UNKNOWN OPERATOR COMMAND>>           01435000
   TOOMANYPARM           = 3099, <<(DIS)ALLOW TOO MANY PARMS>>          01440000
   ALLDISALLIOERR        = 3100, <<I/O ON FILE =  FILE>>                01445000
   NOJOBINGOODSTATE      = 3101, <<NO JOBS IN EXECUTION STATE>>         01450000
   EXP1OFONOFF           = 3102, <<EXPECTED ON/OFF IN VMOUNT>>          01455000
   EXPALL                = 3103, <<EXPECTED ;ALL>>                      01460000
   REQSETGRPACCT         = 3104, <<EXPECTED SET.GROUP.ACCT>>            01465000
   LMHAS5PARMS           = 3105, <<LMOUNT HAS AT MOST 5 PARMS>>         01470000
   LDMEXP3PARMS          = 3106, <<LDISMOUNT HAS EXCTLY 3 PARMS>>       01475000
   BADSETNAME            = 3107, <<BAD VOLUME SET/CLASS NAME>>          01480000
   SETNAMEPERIOD         = 3108, <<EXPECTED "." AFTER SET NAME>>        01485000
   GROUPPERIOD           = 3109, <<EXPECTED "." AFTER GRP NAME>>        01490000
   EXPGENERATION         = 3110, <<EXPECTED ;GEN = >>                   01495000
   BADGENERATION         = 3111, <<INVALID GENERATION #>>               01500000
   MONMAXPARM            = 3112, <<TOO MANY PARMS FOR MON>>             01505000
   MONREQLDEV            = 3113, <<EXPECTED LDEV FOR MON>>              01510000
   NOSYSBUF              = 3114, <<NO SYSBUFS FOR MONITORING>>          01515000
   MONMUSTBETAPE         = 3115, <<MON LDEV MUST BE TAPE>>              01520000
   TAPEMUSTBEDOWN        = 3116, <<LDEV MUST BE DOWN FOR MON>>          01525000
   EXPSEMI'E'EQUALS      = 3117, <<EXPECTED ;E = >>                     01530000
   MASKCOMMA             = 3120, <<EXP "," AFTER MASK BIT #>>           01535000
   IGNOREDNULL           = 3121, <<IGNORED NULL MASK BIT #>>            01540000
   BADMASK               = 3122, <<INVALID MASK BIT SPECIFIED>>         01545000
   NODS                  = 3123, <<NO DS SUBSYSTEM>>                    01550000
   NOMP                  = 3124, <<NO MULTI-POINT SUBSYSTEM>>           01555000
   NOMRJE                = 3125, <<NO MRJE SUBSYSTEM>>                  01560000
   EXPAUTO               = 3126, <<EXPECTED "AUTO" AFTER "ON">>         01565000
   INVALIDNAME           = 3127, <<NAME MUST BE 1-8 CHARS,A/N>>         01570000
   JOBSECURITY1PARM      = 3128, <<JOBSECURITY HAS 1 PARM>>             01575000
   EXP1OFHIGHLOW         = 3129, <<EXPECTED EITHER HIGH OR LOW>>        01580000
   LDEVMUSTBETERM        = 3130, <<CONSOLE LDEV MUST BE TERM>>          01585000
   LDEVCANTBEDSTERM      = 3131, <<CONSOLE LDEV CANT BE DS TERM>>       01590000
   DEVNOTASS             = 3132, <<MASTEROP TRIED TO DISASSOC>>         01595000
                                 <<  NON-ASSOC DEVICE>>                 01600000
   LDEVWASASS            = 3133, <<CONFIRM ASSOC TO MASTEROP>>          01605000
   LDEVWASDISASS         = 3134, <<CONFIRM DISASSOC TO MASTEROP>>       01610000
   OTHERUSERHASDEV       = 3135, <<REQUIRE MASTEROP TO VERIFY>>         01615000
                                 <<  DEV COMMAND>>                      01620000
   OPNOTDONE             = 3136, <<OPERATOR DIDN'T VERIFY>>             01625000
   EXPFILESHOW           = 3137, <<EXPECTED FILE = FORMAL[;SHOW]>>      01630000
   EXPSHOW               = 3138, <<EXPECTED ;SHOW>>                     01635000
   LASTALLOW             = 3139, <<LAST CMPLT INP LINE WAS :>>          01640000
   MASTEROPDISASS        = 3140, <<MASTER OP DISASS. SOMEBODY>>         01645000
   NOSUCHDEVCLASS        = 3141, <<NO SUCH DEVICE CLASS>>               01650000
   ASSREQSESSION         = 3142, <<(DIS)ASSOC AVAIL ONLY TO SES>>       01655000
   LDEVNOTINIDD          = 3143, <<LDEV NOT IN IDD>>           <<07438>>01660000
   OTHERUSERHASCLASS     = 3143, <<REQ MASTEROP TO VERIFY>>             01665000
                                 <<  CLASS COMMAND>>                    01670000
                                 <<  (in $SET 7)  >>           <<07438>>01675000
   CONSOLEBUSY           = 3144, <<CONSOLE IS BUSY>>           <<04833>>01680000
   CONSOLESWITCHED       = 3145, <<CONS SWCH FROM LDEV TO LDEV>>        01685000
                                 <<  (in $SET 7)             >><<07438>>01690000
   OUTFENCEXP3PARMS      = 3146, <<OUTFENCE EXPCT 3 PARMS>>    <<04833>>01695000
   EXPLDEVEQ             = 3147, <<EXPECTED "LDEV=">>          <<04833>>01700000
   LDEVNOTINODD          = 3148, <<LDEV NOT IN ODD>>           <<04833>>01705000
   CONSOLEDOWN           = 3149, <<CONS DOWN OR PENDING>>      <<04833>>01710000
   DOWNCONSOLE           = 3150, <<ATTEMPT TO DOWN CONSOLE>>   <<04833>>01715000
   CANT'DOWN'SYS'DISC    = 3151, << Attempt to down sysdisc.>> <<04833>>01720000
   CANTABORTIODISK       = 3160, <<Can't do ABORTIO on disc >> <<04833>>01725000
   CONSOLEIS             = 3190, <<Display current cons ldev>> <<04833>>01730000
   ABSLIMITEXCEEDED      = 3818, << Absolute J/S limit exc >>  <<04833>>01735000
   CONF'ERROR            = 3819; << CONFDATA.PUB.SYS error >>  <<04833>>01740000
$PAGE "SPOOLING ERROR MESSAGES"                                         01745000
<< Spooling error messages added as part of this fix.       >> <<04833>>01750000
                                                                        01755000
EQUATE                                                                  01760000
   EXPSPFNAME = 3200,     <<EXPECTED SPOOLFILE DFID>>                   01765000
   FILENUMNOOTHERP = 3201,<<EXPECTED ONE PARM DFID>>                    01770000
   EXPOORINUM = 3202,     <<EXPECTED #ONNN OR #INNN>>                   01775000
   BADFILENUM = 3203,     <<DFID MUST BE POSITIVE INTEGER>1>>           01780000
   NOSUCHFILE = 3204,     <<DFID DOES NOT EXIST>>                       01785000
   WRONGSTATE = 3205,     <<DFID NOT READY     >>                       01790000
   NOPOUNDSIGN = 3206,    <<DFID MUST START WITH # SIGN>>               01795000
   SPACTLDEV=3207,        <<SPOOLFILE IS ACTIVE ON LDEV \>>             01800000
   EXPONUM = 3208,         <<EXPECTED DFID OF #ONNN>>                   01805000
   EXP1OFKEY = 3209,       <<EXPECT 1 OF DEV,PRI,DEFER,COPIES>>         01810000
   EXP1TO127 = 3210,       <<EXPECT NUMBER 1<=COPIES<=127>>             01815000
   EXPOAND1PARM = 3211,    <<EXPECT DFID AND ONE PARM>>                 01820000
   EXPO0TO14 = 3212,        <<EXPECTS 0 <= PRI <= 14 >>                 01825000
   STARTSPREQ1P = 3213,     <<STARTSPOOL REQUIRES 1 PARM>>              01830000
   INVDEVCLASS  = 3214,     <<INVALID DEVICE CLASS >>                   01835000
   UNKNOWNDEVCL = 3215,     <<UNKNOWN DEVICE CLASS >>                   01840000
   EXPINOROUT   = 3216,     <<EXPECTED IN OR OUT IN REPLY>>             01845000
   DEVTYPENOTSPOOLEE=3217,  <<DEVICE NOT SPOOLEE TYPE>>                 01850000
   SPOOLEEOWNEDOUT=3218,    <<DEVICE ALREADY OUTPUT SPOOLEE>>           01855000
   SPOOLEEOWNEDIN =3219,    <<DEVICE ALREADY INPUT SPOOLEE>>            01860000
   DEVOWNEDOTHER = 3220,    <<DEVICE OWNED BY ANOTHER PROC>>            01865000
   DEVNOTJOBDATA = 3221,    <<DEVICE NOT JOB/DATA ACCEPTING>>           01870000
   DEVOWNEDDIAG = 3222,     <<DEVICE OWNED BY DIAGNOSTICS>>             01875000
   UNABLETOGETSTACK=3223,   <<UNABLE TO GET SPOOLER STACK>>             01880000
   UNABLETOPROCREATE=3224,  <<UNABLE TO CREATE SPOOLER PROC>>           01885000
   STOPSPREQ1P = 3225,      <<STOPSPOOL REQUIRES 1 PARM>>               01890000
   SPOOLERBUSY = 3226,      <<SPOOLER PROCESS BUSY>>                    01895000
   CANT'DELETE'STDIN = 3227,                                   <<04833>>01900000
   SPOOLINOROUT = 3227,     <<IS SPOOLER INPUT OR OUTPUT?>>             01905000
                            <<  (in $SET 7)              >>             01910000
   DEVICENOTSPOOLED = 3228, <<DEVICE IS NOT SPOOLED>>                   01915000
   EXP1OFLDEVORFIN = 3229,  <<EXPECTED 1 OF LDEV OR FINISH>>            01920000
   SUSPENDSP2PARM  = 3230,  <<SUSPENDSPOOL EXP MAX 2 PARMS>>            01925000
   EXPFINISH = 3231,        <<EXPECTED "FINISH" PARAMETER>>             01930000
   RESUMESPREQ1P = 3232,    <<RESUMESP REQUIRES 1 PARM >>               01935000
   DEFEROVERPRI = 3233,      <<DEFER OVERRIDES PRI>>                    01940000
   PRIOVERDEFER = 3234,      <<PRI OVERRIDES DEFER>>                    01945000
   PRIOVERPRI = 3235,        <<PRI OVERRIDES PRI>>                      01950000
   SPACTLDEVNODEL = 3236,    <<SPFLE ACTIVE ON LDEV,NOT DELETE>>        01955000
   DEVICENOTOUTSPOOL = 3237, <<DEVICE NOT SPOOLED FOR OUTPUT>>          01960000
   EXPBACKORFORWARD = 3238,   <<EXPECTED "BACK" OR "FORWARD">> <<04833>>01965000
   EXPNUM1TO256 = 3239,       <<EXPECTED RANGE 1 TO 256>>      <<04833>>01970000
   EXPPAGESORFILES = 3240,    <<EXPECTED "PAGES" OR "FILES">>  <<04833>>01975000
   EXP4PARMS = 3241,          <<EXPECTED AT MOST 4 PARMS>>     <<04833>>01980000
   EXPDEVCLASSLONG = 3242,  <<DEVCLASS NAME > 8 CHARS>>        <<04833>>01985000
   BADCLASSNAME  = 3243,    <<CLASS NOT CONFIGURED>>           <<04833>>01990000
   CLASSALREADYSPOOLED = 3244, <<CLASS ALREADY SPOOLED>>       <<04833>>01995000
   CLASSNOTSPOOLED = 3245,  <<CLASS NOT SPOOLED>>              <<04833>>02000000
   CLTYPENOTSPOOLEE = 3246, <<DEVCLASSTYPE NOT SPOOLEE>>       <<04833>>02005000
   USERNOACC2CLASS = 3247, <<USER HAS NO ACCESS TO CLASS>>     <<04833>>02010000
   LDEVNOTACTIVE = 3248,      <<LDEV IS NOT ACTIVE >>          <<04833>>02015000
   RESUMESPBEGINX = 3249,   <<EXTRA PARMS AFTER "BEGINNING">>  <<04833>>02020000
   EXPBLANK       = 3250,    <<EXPECTED BLANK DELIMITER>>      <<04833>>02025000
   EXP1OFLDEVORSHUTQ = 3251, <<EXPECTED LDEV;[SHUTQ]>>         <<04833>>02030000
   EXP1OFLDEVOROPENQ = 3252, <<EXPECTED LDEV;[OPENQ]>>         <<04833>>02035000
   STARTSP2PARM      = 3253, <<STARTSPOOL EXP 2 PARMS>>        <<04833>>02040000
   STOPSP2PARM       = 3254, <<STOPSPOOL EXP 2 PARMS>>         <<04833>>02045000
   EXPSHUTQ          = 3255, <<STARTSPOOL EXP SHUTQ>>          <<04833>>02050000
   EXPOPENQ          = 3256, <<STOPSPOOL EXP OPENQ>>           <<04833>>02055000
   CLASSXPARMS       = 3257, <<EXTRA PARMS AFTER CLASS>>       <<04833>>02060000
   DEVICEACTIVE   = 3258,    <<DEVICE IS ACTIVE>>              <<04833>>02065000
   SHUTQINPUT     = 3259, <<SHUTQ INVALID INPUT SPOOLEE>>      <<04833>>02070000
   OPENQINPUT     = 3260, <<OPENQ INVALID INPUT SPOOLEE>>      <<04833>>02075000
   DEVISDOWN      = 3261, <<DEV DOWNED ON START SPOOLER>>      <<06914>>02080000
   OPENQ1PARM     = 3262, << openq requires 1 parm >>          <<06914>>02085000
   SHUTQ1PARM     = 3263, << shutq requires 1 parm >>          <<06914>>02090000
   EXPLDEVORCLASS = 3264, << expected ldev or device class >>  <<06914>>02095000
   DEV'Q'OPEN     = 3265, << device queue already open       >><<06914>>02100000
   DEV'CL'Q'OPEN  = 3266, << device class queue already open >><<06914>>02105000
   DEV'Q'SHUT     = 3267, << device queue already shut       >><<06914>>02110000
   DEV'CL'Q'SHUT  = 3268; << device class queue already shut >><<06914>>02115000
$PAGE "ALLOW MASK EQUATES"                                              02120000
$page                                                          <<06744>>02125000
$SET X8 = ON        << Expand INCLUDE file comments.        >> <<07438>>02130000
$INCLUDE INCLAMSK                                              <<07438>>02135000
$PAGE "***   SYSTEM GLOBAL TABLE - SYSDB   ***"                         02140000
<< SYSTEM GLOBAL TABLE - SYSDB >>                                       02145000
EQUATE                                                                  02150000
           EXTSSECT          = %104  ,                                  02155000
           SPOOLINDEX        = %132  ,                                  02160000
           JOBSYNC           = %121  ,                                  02165000
           SINPLABEL         = %161  ,                                  02170000
           SINDELTAP         = %164  ,                                  02175000
           SOUTPLABEL        = %165  ,                                  02180000
           SOUTDELTAP        = %166  ;                                  02185000
DEFINE                                                                  02190000
           ABSYS             = %1000              #,                    02195000
           ABSYS'LPDTBASE    = A(ABSYS+LPDTBASE)  #,                    02200000
           ABSYS'EXTSSECT    = A(ABSYS+EXTSSECT)  #,                    02205000
           ABSYS'SPOOLINDEX  = A(ABSYS+SPOOLINDEX)#,                    02210000
           JOBSYNCADDR       = ABSYS +JOBSYNC     #,                    02215000
           ABSYS'JOBSYNC     = A (JOBSYNCADDR)    #,                    02220000
             JOBREADY'F      = 13:1               #,                    02225000
             DEVFREED'F      = 14:1               #,                    02230000
             JOBWAITING'F    = 15:1               #,                    02235000
           ABSYS'UCOPPCBT    = A(ABSYS+PCBT+UCOPPCBT)#,                 02240000
           ABSYS'SINPLABEL   = A(ABSYS+SINPLABEL) #,                    02245000
           ABSYS'SINDELTAP   = A(ABSYS+SINDELTAP) #,                    02250000
           ABSYS'SOUTPLABEL  = A(ABSYS+SOUTPLABEL)#,                    02255000
           ABSYS'SOUTDELTAP  = A(ABSYS+SOUTDELTAP)#;                    02260000
$INCLUDE INCLPCB5                                              <<07438>>02265000
$PAGE "***   PROCESS CONTROL BLOCK - PCB   ***"                         02270000
EQUATE                                                                  02275000
           DADWAIT           = 1        ,                               02280000
           SONWAIT           = 2        ,                               02285000
           JUNKWAIT          = %20      ;                               02290000
EQUATE                                                                  02295000
           UCOPLPIN          = 2        ;                               02300000
$INCLUDE  INCLLPDT                                             <<06744>>02305000
$INCLUDE INCLLDT5                                              <<06744>>02310000
                                                               <<04833>>02315000
$INCLUDE INCLDCT                                               <<06744>>02320000
                                                               <<04833>>02325000
                                                               <<04833>>02330000
<< GETCLASS image of Device Class Table entry. >>              <<04833>>02335000
                                                               <<04833>>02340000
DEFINE                                                         <<04833>>02345000
           C'SQ              = GETCLASSBUF(2).( 8:1)#,         <<04833>>02350000
           C'DEVTYPE         = GETCLASSBUF(2).(10:6)#,         <<06744>>02355000
           C'FIRST'LDEV      = GETCLASSBUF(4)#,                <<06744>>02360000
           C'CLYCLICAL'PTR   = GETCLASSBUF(2).(1:7)#,          <<06744>>02365000
           C'NUM'DEVICES     = GETCLASSBUF(3)#,                <<06744>>02370000
           C'TERM'CLASS      = GETCLASSBUF(2).(9:1)#;          <<06744>>02375000
                                                               <<06744>>02380000
<< DEFINES FOR GETDEVINFO RETURNS       >>                     <<06744>>02385000
                                                               <<06744>>02390000
EQUATE                                                         <<06744>>02395000
   SIZE'OF'GETDEVINFO        =12, <<SIZE OF RETURNED ARRAY>>   <<06744>>02400000
   GETDEVINFO'LPDT'OFFSET    = 2, << LPDT OFFSET IN DEVINFO >> <<06744>>02405000
   GETDEVINFO'LDT'OFFSET     = 6; << LDT OFFSET IN DEVINFO >>  <<06744>>02410000
                                                               <<06744>>02415000
DEFINE                                                         <<06744>>02420000
   G'DCT'INDEX               = DEVINFO(0)#,                    <<06744>>02425000
   G'ACCESS'TYPE             = DEVINFO(1)#,                    <<06744>>02430000
   G'XDD'HEAD'INDEX          = DEVINFO(10).(8:8)#,             <<07060>>02435000
   G'LDT'ACCESS'TYPE         = DEVINFO(8).(10:3)#;             <<07060>>02440000
                                                               <<06744>>02445000
$PAGE "***   COMMON FIELDS OF JMAT, IDD, ODD   ***"                     02450000
$INCLUDE INCLXDD5                                              <<06744>>02455000
$PAGE "MPE TABLE ACCESS:  Job Master Table (JMAT)"             <<F9095>>02460000
$INCLUDE INCLJMAT                                              <<06744>>02465000
$PAGE                                                          <<06744>>02470000
                                                               <<06744>>02475000
                                                               <<06744>>02480000
<<* * * ADDITIONAL JMAT EQUATES * * *>>                        <<06744>>02485000
                                                               <<06744>>02490000
EQUATE                                                         <<06744>>02495000
                                                               <<06744>>02500000
              JOBINTRO       = 1                  ,            <<06744>>02505000
              JOBWAIT        = %40                ,            <<06744>>02510000
              JOBINIT        = %60                ,            <<06744>>02515000
              JOBEXEC        = 2                  ,            <<06744>>02520000
              JOBDONE        = 3                  ,            <<06744>>02525000
              JOBSUSP        = 4                  ,            <<06744>>02530000
              JOBERR         = %50                ;            <<06744>>02535000
                                                               <<06744>>02540000
<<     JOB TYPES     >>                                        <<06744>>02545000
                                                               <<06744>>02550000
EQUATE                                                         <<06744>>02555000
                                                               <<06744>>02560000
         SESSION'            = 0,                              <<06744>>02565000
         SESSION             = 1,                              <<06744>>02570000
         JOB'                = 2,                              <<06744>>02575000
         JOB                 = 3;                              <<06744>>02580000
                                                               <<06744>>02585000
$PAGE "MPE TABLE ACCESS:  Job Information Table (JIT)"         <<F9095>>02590000
$INCLUDE INCLJIT                                               <<06744>>02595000
$PAGE "MPE TABLE ACCESS:  PXGlobal area (PXG)"                 <<F9095>>02600000
$INCLUDE INCLPXG                                               <<06744>>02605000
                                                               <<06744>>02610000
$INCLUDE INCLFLAB                                              <<07063>>02615000
$INCLUDE INCLSYSG                                              <<07438>>02620000
$PAGE "***   SPOOLER STACK   ***"                                       02625000
COMMENT  <<P>> MEANS PROGEN INITIALIZES VARIABLE;                       02630000
                                                                        02635000
<< PROGEN -> SPOOLER COMMUNICATION >>                                   02640000
   EQUATE  DIRECTIV          = 0                 ;                      02645000
   EQUATE  PRIORDIRECTIVE    = 0                 ,                      02650000
           QUITSPOOLING      = 1                 ,                      02655000
           WAITSPOOLING      = 2                 ,                      02660000
           RESUMESPOOLING    = 3                 ,                      02665000
           KEEPSPOOLING      = RESUMESPOOLING    ,                      02670000
           FINISHFILE        = 0                 ,                      02675000
           DELETEFILE        = 1                 ,                      02680000
           DEFERFILE         = 2                 ,                      02685000
           RELINKFILE        = 3                 ;                      02690000
   LOGICAL SPOOLREQUEST      = DB+1              ,                      02695000
           FILEREQUEST       = DB+2              ;                      02700000
                                                                        02705000
<< SPOOLER CONTROL >>                                                   02710000
   INTEGER SPOOLEE           = DB+3              ,<<P>>                 02715000
           DEVICE            = SPOOLEE           ;                      02720000
   EQUATE  SPOOLE            = 3                 ;                      02725000
   INTEGER DEVICEFILE        = DB+7              ,                      02730000
           SPOOLFILE         = DB+8              ;                      02735000
   LOGICAL SPOOLER           = DB+9              ;                      02740000
   INTEGER DEVICETYPE        = DB+10             ;                      02745000
<< DEVICE RECOGNITION >>                                                02750000
   LOGICAL DEVRECFLAGS       = DB+12             ,                      02755000
           OUTFLAGS          = DEVRECFLAGS       ;                      02760000
   DEFINE  PROMPTING         = DEVRECFLAGS.(0:1) #;            <<S8948>>02765000
    EQUATE  BLOCKS              = 8 <<# OF 512 WORD BLOCKS>>,  <<01549>>02770000
                                    << IN BUFFER          >>   <<01549>>02775000
            EPOC'SUBTYPE        = 8                  ;         <<01549>>02780000
   DEFINE READERPUNCH        = 20#;   <<READER PUNCH DEV TYPE>><<06744>>02785000
                                                                        02790000
<< BUFFER/RECORD CONTROL >>                                             02795000
   BYTE PSEUDOCOLON          = DB+15             ;                      02800000
   EQUATE  INBUFS            = 2                 ,                      02805000
           OUTBUFS           = 8                 ;             <<02548>>02810000
   INTEGER DEVICERECL        = DB+18             ,                      02815000
           RECL              = DB+19             ;                      02820000
   INTEGER POINTER DEVICERECP= DB+20             ,                      02825000
                   RECP      = DB+21             ;                      02830000
                                                                        02835000
<< REAL WORLD >>                                                        02840000
INTEGER CIERRNUM  = DB+28             ,                        <<00534>>02845000
        CIPARMNUM = DB+29             ;                        <<00534>>02850000
   INTEGER POINTER JMATP     = DB+30             ,                      02855000
                   OUTCLASSES= JMATP             ,                      02860000
                   XDDEP     = DB+31             ,                      02865000
                   IDDEP     = XDDEP             ,                      02870000
                   ODDEP     = XDDEP             ,                      02875000
                   ODDXP     = DB+32             ,                      02880000
                   LDTP      = DB+33             ,                      02885000
                   DEVHP     = DB+34             ,                      02890000
                   CLASSHP   = DB+35             ;                      02895000
   INTEGER DEVFILEID         = DB+36             ,                      02900000
           JOBNUMBER         = DB+37             ,                      02905000
           STREAMDEV         = DB+38             ,                      02910000
           LISTTYPE          = DB+39             ,                      02915000
           LISTSIZE          = DB+40             ,                      02920000
           STACKDST          = DB+41             ,                      02925000
           JLISTED           = DB+42             ,                      02930000
           ORIGDEST          = DB+43             ;                      02935000
   DOUBLE   LINES'PRINTED     = DB+44              ;           <<B0.SZ>>02940000
                                                               <<M8206>>02945000
<< The following variables are used by  the  input  spooler >> <<S8948>>02950000
<< when  :STREAMing  jobs for future execution.  They share >> <<S8948>>02955000
<< the locations with the  doubleword  REC'COUNT  and  with >> <<S8948>>02960000
<< CHANNELSKIP, which are not used by the input spooler.    >> <<S8948>>02965000
                                                               <<M8206>>02970000
   LOGICAL ARRAY FUTURE'TIME(*) = DB+58;   << A doubleword. >> <<S8948>>02975000
   INTEGER FUTURE'DATE       = DB+60;                          <<S8948>>02980000
$PAGE "   ***   SPOOLER INFO FOR PROGEN   ***"                          02985000
    INTEGER DEVICE'SUBTYPE      = DB+65;                       <<01549>>02990000
    LOGICAL BLOCKMODE           = DB+66;                       <<01549>>02995000
    DEFINE  PAGEPRINTER         = DEVICETYPE = PRINTER AND     <<01549>>03000000
                             DEVICE'SUBTYPE = EPOC'SUBTYPE #;  <<01549>>03005000
<< SPOOLER INITIATION PARAMETERS >>                                     03010000
   EQUATE                                                               03015000
           INITDIRECTIVE = [ 1/1 ,                                      03020000
                             7/0 ,                                      03025000
                             4/KEEPSPOOLING ,                           03030000
                             4/FINISHFILE ],                            03035000
           SPOOLPRI = 140;                                              03040000
                                                                        03045000
<< SPOOLER STACK DATA SEGMENT SIZES >>                                  03050000
   INTEGER POINTER   DBP  = DB+1;      <<PNTR 2 DB FROM PCBX>>          03055000
   EQUATE                                                               03060000
           FUNC'LOAD'VFC = 64,   << These two values define >> <<06744>>03065000
           MAX'FUNC      = 255,  << length of a Q+ table in >> <<06744>>03070000
                                 << the output spooler.     >> <<06744>>03075000
           PCBXSIZE = 512,  <<AT MOST!>>                                03080000
           GLOBSIZE = 90,                                      <<06744>>03085000
           LOCSIZE = 768 + BSIZE + RSIZE + INBUFS*RSIZE +      <<06744>>03090000
                       (MAX'FUNC - FUNC'LOAD'VFC + 2)/2,       <<06744>>03095000
           INITSTACKSIZE = PCBXSIZE + 30 + GLOBSIZE +LOCSIZE; <<<01549>>03100000
                                                               <<04833>>03105000
DEFINE EXECUTORHEAD= (PARMSP,ERRNUM,PARMNUM);                  <<04833>>03110000
                     BYTE ARRAY PARMSP;                        <<04833>>03115000
                     INTEGER ERRNUM, PARMNUM;                  <<04833>>03120000
                     OPTION PRIVILEGED,UNCALLABLE #;           <<04833>>03125000
                                                                        03130000
<< DECLARATIONS FOR PARAMETER PARSING >>                                03135000
   DEFINE            P'DECLARATIONS =                                   03140000
      INTEGER           NUMPARMS;                                       03145000
      DOUBLE ARRAY      PARMS (1:MAXPARMS);                             03150000
      BYTE POINTER      PP;                                             03155000
      BYTE              PLEN;                                           03160000
      INTEGER           PDELWD = PLEN;                                  03165000
      DOUBLE            PARM = PP;                                      03170000
      EQUATE            COMMA = 0,                                      03175000
                        EQUAL = 1,                                      03180000
                        SEMI = 2,                                       03185000
                        CR = 3;                                         03190000
      INTEGER           PNUM := 0    #,                                 03195000
      PSPECIAL          = LOGICAL (PDELWD.(10:1))  #,                   03200000
      PDEL              = PDELWD.(11:5)  #;                             03205000
                                                                        03210000
                                                               <<04833>>03215000
<< MYCOMMAND PARAMETER DESCRIPTION AREA LAYOUT>>               <<04833>>03220000
                                                               <<04833>>03225000
DEFINE DELIMITER=(11:5)#, SPECIAL'CHAR=(10:1)#,                <<04833>>03230000
       ALPHA'CHAR=(8:1)#, NUMERICAL'CHAR=(9:1)#;               <<04833>>03235000
$PAGE "   ***   MOVExxxxDSEG DEFINEs   ***"                    <<W7675>>03240000
<<        DEF'MOVEFROMDSEG          >>                         <<00548>>03245000
<< To use, declare SUBROUTINE DEF'MOVEFROMDSEG >>              <<00548>>03250000
   DEFINE                                                      <<00548>>03255000
   DEF'MOVEFROMDSEG =                                          <<00548>>03260000
      MOVEFROMDSEG(DBTARGET,DSTN,DSTOFFSET,COUNT);             <<00548>>03265000
         VALUE DBTARGET,DSTN,DSTOFFSET,COUNT;                  <<00548>>03270000
         LOGICAL POINTER DBTARGET;                             <<00548>>03275000
         LOGICAL DSTN,DSTOFFSET,COUNT;                         <<00548>>03280000
      BEGIN                                                    <<00548>>03285000
         X := TOS; << SAVE RETURN ADDRESS >>                   <<00548>>03290000
         ASSEMBLE(MFDS 0);                                     <<00548>>03295000
         TOS := X; << RESTORE RETURN ADDRESS >>                <<00548>>03300000
      END #,                                                   <<00548>>03305000
                                                               <<00548>>03310000
<<        DEF'MOVETODSEG            >>                         <<00548>>03315000
<< To use, declare SUBROUTINE DEF'MOVETODSEG >>                <<00548>>03320000
   DEF'MOVETODSEG =                                            <<00548>>03325000
      MOVETODSEG(DSTN,DSTOFFSET,DBSOURCE,COUNT);               <<00548>>03330000
         VALUE DSTN,DSTOFFSET,DBSOURCE,COUNT;                  <<00548>>03335000
         LOGICAL POINTER DBSOURCE;                             <<00548>>03340000
         LOGICAL DSTN,DSTOFFSET,COUNT;                         <<00548>>03345000
      BEGIN                                                    <<00548>>03350000
         X := TOS;                                             <<00548>>03355000
         ASSEMBLE(MTDS 0);                                     <<00548>>03360000
         TOS := X;                                             <<00548>>03365000
      END #,                                                   <<07438>>03370000
                                                               <<07438>>03375000
<<        DEF'MOVEDSEG              >>                         <<07438>>03380000
<< To use, declare SUBROUTINE DEF'MOVEDSEG   >>                <<07438>>03385000
   DEF'MOVEDSEG =                                              <<07438>>03390000
      MOVEDSEG   (DESTINATION'DST, DESTINATION'OFFSET,         <<07438>>03395000
                 SOURCE'DST, SOURCE'OFFSET, WORD'COUNT);       <<07438>>03400000
         VALUE   DESTINATION'DST, DESTINATION'OFFSET,          <<07438>>03405000
                 SOURCE'DST, SOURCE'OFFSET, WORD'COUNT;        <<07438>>03410000
         LOGICAL DESTINATION'DST, DESTINATION'OFFSET,          <<07438>>03415000
                 SOURCE'DST, SOURCE'OFFSET, WORD'COUNT;        <<07438>>03420000
      BEGIN                                                    <<07438>>03425000
      X := TOS;                                                <<07438>>03430000
      ASSEMBLE (MDS 0);                                        <<07438>>03435000
      TOS := X;                                                <<07438>>03440000
      END #;                                                   <<07438>>03445000
$PAGE             "GLOBAL NRJE SPOOLER PROCEDURE DECLARATIONS" <<06915>>03450000
COMMENT:                                                       <<06915>>03455000
+-------------------------------------------------------+      <<06915>>03460000
|                                                       |      <<06915>>03465000
|       GLOBAL NRJE SPOOLER PROCEDURE DECLARATIONS      |      <<06915>>03470000
|                                                       |      <<06915>>03475000
+-------------------------------------------------------+      <<06915>>03480000
                                                               <<06915>>03485000
An NRJE reader is a virtual card reader.  The NRJE reader      <<06915>>03490000
is a logical device with device type 22, subtype 2. Spool      <<06915>>03495000
files are associated with the NRJE reader logical device.      <<06915>>03500000
An NRJE process acts as spooler, reading the spool files       <<06915>>03505000
and sending data across a communications link.  NRJE pro-      <<06915>>03510000
cesses call NRJE spooler procedures in order to access         <<06915>>03515000
the LDT, LPDT, and ODD tables.  The processes obtain in-       <<06915>>03520000
formation about the NRJE reader, alter the state of the        <<06915>>03525000
NRJE reader, and access NRJE reader spool files.  All of       <<06915>>03530000
the procedures are privileged and uncallable.  Also, the       <<06915>>03535000
procedures cannot be called in split stack mode.  If a         <<06915>>03540000
procedure is called in split stack or passed a status          <<06915>>03545000
parameter which is out of bounds, the procedure will call      <<06915>>03550000
the quit intrinsic which will result in a system failure       <<06915>>03555000
if the caller is critical.                                     <<06915>>03560000
                                                               <<06915>>03565000
END OF COMMENT;                                                <<06915>>03570000
                                                               <<06915>>03575000
                                                               <<06915>>03580000
                                                               <<06915>>03585000
                                                               <<06915>>03590000
<< Below are the status codes returned by NRJE spooler >>      <<06915>>03595000
<< procedures.  The procedures also return file system >>      <<06915>>03600000
<< error codes which are positive.                     >>      <<06915>>03605000
                                                               <<06915>>03610000
EQUATE   BADRECID           =-17,                              <<06915>>03615000
         BADSTATE           =-16,                              <<06915>>03620000
         CLASSNOTASSOC1DEV  =-15,                              <<06915>>03625000
         NOSPOOLFILES       =-14,                              <<06915>>03630000
         ENDOFSPOOLFILE     =-13,                              <<06915>>03635000
         BADDB              =-12,                              <<06915>>03640000
         BADITEMSCOUNT      =-11,                              <<06915>>03645000
         PARMOUTBOUNDS      =-10,                              <<06915>>03650000
         BADITEM            =-9,                               <<06915>>03655000
         BADCLASS           =-8,                               <<06915>>03660000
         BADDEV             =-7,                               <<06915>>03665000
         BADQUEUE           =-6,                               <<06915>>03670000
         BADVALUE           =-5,                               <<06915>>03675000
         BADSTRINGITEMSCOUNT=-4,                               <<06915>>03680000
         DEVHASNOFENCE      =-3,                               <<06915>>03685000
         BADINDEX           =-2,                               <<06915>>03690000
         BADSTRINGITEM      =-1,                               <<06915>>03695000
         OK                 = 0;                               <<06915>>03700000
                                                               <<06915>>03705000
                                                               <<06915>>03710000
<< Lowest configurable, logical device number          >>      <<06915>>03715000
                                                               <<06915>>03720000
EQUATE  LDEVMIN      = 1;                                      <<06915>>03725000
                                                               <<06915>>03730000
<< NRJE type and subtype equates                       >>      <<06915>>03735000
                                                               <<06915>>03740000
EQUATE NRJETYPE    = 22,                                       <<06915>>03745000
       NRJESUBTYPE = 2;                                        <<06915>>03750000
                                                               <<06915>>03755000
<< MPE/HP3000 dependent constants                      >>      <<06915>>03760000
                                                               <<06915>>03765000
EQUATE  BYTESPERWORD   = 2,                                    <<06915>>03770000
        ROUNDUP        = BYTESPERWORD/2,                       <<06915>>03775000
        WORDSPERSECTOR = 128;                                  <<06915>>03780000
                                                               <<06915>>03785000
$PAGE                                                          <<06915>>03790000
COMMENT:                                                       <<06915>>03795000
+-------------------------------------------------------+      <<06915>>03800000
|                                                       |      <<06915>>03805000
|      SPOOLFILE BLOCK ACCESS DEFINES AND EQUATES       |      <<06915>>03810000
|                                                       |      <<06915>>03815000
+-------------------------------------------------------+      <<06915>>03820000
                                                               <<06915>>03825000
                                                               <<06915>>03830000
Spool File Block Format                                        <<06915>>03835000
                                                               <<06915>>03840000
A spool file block is a 512 word block which contains          <<06915>>03845000
variable length records in spooler format.  Each record        <<06915>>03850000
contains a five word header which contains the following       <<06915>>03855000
information:  the number of bytes in the record not in-        <<06915>>03860000
cluding this byte count word, the number of bytes in the       <<06915>>03865000
data portion of the record including any trailing blanks       <<06915>>03870000
that have been truncated, a function code, and two func-       <<06915>>03875000
tion code parameters.                                          <<06915>>03880000
                                                               <<06915>>03885000
The NRJE product has obtained the fdeviccontrol (func-         <<06915>>03890000
tion) code 193.  NRJE will use the fdevicecontrol MPE          <<06915>>03895000
primitive to record compression, compaction, and trans-        <<06915>>03900000
lation information in a spool file.  The NRJE fdevice-         <<06915>>03905000
control parameters are defined as follows:                     <<06915>>03910000
                                                               <<06915>>03915000
                                                               <<06915>>03920000
   parameter 1:  Indicates character code of spool file        <<06915>>03925000
                 data.                                         <<06915>>03930000
                                                               <<06915>>03935000
                 0 - no translation has been performed         <<06915>>03940000
                 1 - data has been translated from             <<06915>>03945000
                     ebcdic to ascii                           <<06915>>03950000
                 2 - data has been translated from ascii       <<06915>>03955000
                     to ebcdic                                 <<06915>>03960000
                 3 - reserved                                  <<06915>>03965000
                 4 - reserved                                  <<06915>>03970000
                 5 - data has been translated from             <<06915>>03975000
                     ebcdik to jis                             <<06915>>03980000
                 6 - data has been translated from jis         <<06915>>03985000
                     to ebcdik                                 <<06915>>03990000
                                                               <<06915>>03995000
    parameter 2: Indicates if spool file data has been         <<06915>>04000000
                 compressed or compacted.  Fields and          <<06915>>04005000
                 legal values are:                             <<06915>>04010000
                                                               <<06915>>04015000
                 (14:1) - 0: Data is not compacted             <<06915>>04020000
                          1: Data is compacted                 <<06915>>04025000
                                                               <<06915>>04030000
                 (15:1) - 0: Data is not compressed            <<06915>>04035000
                        - 1: Data is compressed                <<06915>>04040000
                                                               <<06915>>04045000
The data part of the record consists of a carriage con-        <<06915>>04050000
trol byte and data bytes.                                      <<06915>>04055000
                                                               <<06915>>04060000
The last record in each block is followed by a word of         <<06915>>04065000
-1.  The last two words in the block contain the record        <<06915>>04070000
number of the first record in the block.                       <<06915>>04075000
                                                               <<06915>>04080000
                                                               <<06915>>04085000
                                                               <<06915>>04090000
NRJE Spooler Procedure Commarea Format                         <<06915>>04095000
                                                               <<06915>>04100000
NRJESPOOLREAD returns a spool file record each time it         <<06915>>04105000
is called.  NRJESPOOLREAD, NRJESPOOLREWIND, and NRJE-          <<06915>>04110000
SPOOLOPEN store a spool file block in the commarea             <<06915>>04115000
parameter.  Words 512-513 of the commarea contain the          <<06915>>04120000
number of the block stored in the commarea( first block        <<06915>>04125000
read from spool file is block 0, second, block one, and        <<06915>>04130000
so on).  Word 514 of the commarea contains the offset          <<06915>>04135000
from the beginning of the commarea to the next record          <<06915>>04140000
to access.                                                     <<06915>>04145000
                                                               <<06915>>04150000
       ---------------------------------------                 <<06915>>04155000
       | byte count of entire record - 2     | 0               <<06915>>04160000
       ---------------------------------------                 <<06915>>04165000
       | byte count of data part + end blanks| 1               <<06915>>04170000
       ---------------------------------------                 <<06915>>04175000
       | function code                       | 2               <<06915>>04180000
       ---------------------------------------                 <<06915>>04185000
       | function code parameter 1           | 3               <<06915>>04190000
       ---------------------------------------                 <<06915>>04195000
       | function code parameter 2           | 4               <<06915>>04200000
       ---------------------------------------                 <<06915>>04205000
       | carriage control |   data           | 5               <<06915>>04210000
       ---------------------------------------                 <<06915>>04215000
       |                                     |                 <<06915>>04220000
       |    continuation of data             |                 <<06915>>04225000
       |                                     |                 <<06915>>04230000
       ---------------------------------------                 <<06915>>04235000
       |                                     |                 <<06915>>04240000
       |  next records (len, len, function,  |                 <<06915>>04245000
       |    parm1, parm2, data)              |                 <<06915>>04250000
       |                                     |                 <<06915>>04255000
       ---------------------------------------                 <<06915>>04260000
       |  -1 (no more records in block)      |                 <<06915>>04265000
       ---------------------------------------                 <<06915>>04270000
       |                                     |                 <<06915>>04275000
       |  garbage until end of block         |                 <<06915>>04280000
       |                                     |                 <<06915>>04285000
       ---------------------------------------                 <<06915>>04290000
       |double word record count of 1st re-  | 510             <<06915>>04295000
       ---------------------------------------                 <<06915>>04300000
       |cord in block (count from file start)| 511             <<06915>>04305000
       ---------------------------------------                 <<06915>>04310000
       |  double word block number of cur-   | 512             <<06915>>04315000
       ---------------------------------------                 <<06915>>04320000
       |  rent block                         | 513             <<06915>>04325000
       ---------------------------------------                 <<06915>>04330000
       |  offset of next record to access    | 514             <<06915>>04335000
       ---------------------------------------                 <<06915>>04340000
                                                               <<06915>>04345000
END OF COMMENT;                                                <<06915>>04350000
                                                               <<06915>>04355000
<< Spooler queue nill link                              >>     <<06915>>04360000
                                                               <<06915>>04365000
EQUATE  NILL'LINK    = 0;                                      <<06915>>04370000
                                                               <<06915>>04375000
<< Index passed to NRJE spooler procedures in order to  >>     <<06915>>04380000
<< indicate the first spool file in a spooler queue.    >>     <<06915>>04385000
                                                               <<06915>>04390000
EQUATE  FIRSTINQUEUE = 1;                                      <<06915>>04395000
                                                               <<06915>>04400000
<< Queue passed to NRJE spooler procedures in order to  >>     <<06915>>04405000
<< indicate the device class queue.                     >>     <<06915>>04410000
                                                               <<06915>>04415000
EQUATE  CLASSQUEUE   = 2;                                      <<06915>>04420000
                                                               <<06915>>04425000
<< Value of word following last record in a spool file  >>     <<06915>>04430000
<< block.                                               >>     <<06915>>04435000
                                                               <<06915>>04440000
EQUATE  ENDOFBLOCK       = -1;                                 <<06915>>04445000
                                                               <<06915>>04450000
<< Commarea/spool file block format equates and defines.>>     <<06915>>04455000
                                                               <<06915>>04460000
EQUATE  SIZE'OF'SPBLOCK  = 512,                                <<06915>>04465000
        SIZE'OF'COMMAREA = SIZE'OF'SPBLOCK + 3;                <<06915>>04470000
                                                               <<06915>>04475000
DEFINE  SPRECORD'FUNCTIONCODE          =                       <<06915>>04480000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 2 )#,              <<06915>>04485000
                                                               <<06915>>04490000
        SPRECORD'TRANSLATION           =                       <<06915>>04495000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 3 )#,              <<06915>>04500000
                                                               <<06915>>04505000
        SPRECORD'COMPRESSION           =                       <<06915>>04510000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 4 ).(15:1)#,       <<06915>>04515000
                                                               <<06915>>04520000
        SPRECORD'COMPACTION            =                       <<06915>>04525000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 4 ).(14:1)#,       <<06915>>04530000
                                                               <<06915>>04535000
        SPRECORD'ENDOFBLOCKFLAG        =                       <<06915>>04540000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 0 )#,              <<06915>>04545000
                                                               <<06915>>04550000
        SPRECORD'COUNT                 =                       <<06915>>04555000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 0 ) + 2#,          <<06915>>04560000
                                                               <<06915>>04565000
        SPRECORD'TRUNCDATACOUNT        =                       <<06915>>04570000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 0 ) - 8#,          <<06915>>04575000
                                                               <<06915>>04580000
        SPRECORD'EXPDATACOUNT          =                       <<06915>>04585000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 1 )#,              <<06915>>04590000
                                                               <<06915>>04595000
        SPRECORD'DATA                  =                       <<06915>>04600000
         ICOMMAREA( SPBLOCK'RECORDPOINTER + 5 )#,              <<06915>>04605000
                                                               <<06915>>04610000
        SPBLOCK'RECORDPOINTER          =                       <<06915>>04615000
         ICOMMAREA( SIZE'OF'SPBLOCK + 2 )#,                    <<06915>>04620000
                                                               <<06915>>04625000
        SPBLOCK'BLOCKNUM               =                       <<06915>>04630000
         DCOMMAREA( SIZE'OF'SPBLOCK/2 )#;                      <<06915>>04635000
                                                               <<06915>>04640000
                                                               <<06915>>04645000
$PAGE "***   EXTERNAL PROCEDURES   ***"                                 04650000
                                                                        04655000
PROCEDURE SPOOLINTO;                                                    04660000
   OPTION EXTERNAL;                                                     04665000
                                                                        04670000
LOGICAL PROCEDURE REQUESTSERVICE;                                       04675000
   OPTION EXTERNAL;                                                     04680000
                                                                        04685000
PROCEDURE SLINKXDD (XDDHEADX, XDDENTRYP);                               04690000
   VALUE XDDHEADX, XDDENTRYP;                                           04695000
   INTEGER XDDHEADX;                                                    04700000
   INTEGER POINTER XDDENTRYP;                                           04705000
   OPTION EXTERNAL;                                                     04710000
                                                               <<04833>>04715000
LOGICAL PROCEDURE CHECKALLOW (MASK);                           <<04833>>04720000
   VALUE MASK;                                                 <<04833>>04725000
   LOGICAL MASK;                                               <<04833>>04730000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<04833>>04735000
COMMENT -- CHECKALLOW returns TRUE if the user has been ALLOW- <<04833>>04740000
ed to use the command specified in MASK, or  if  s/he  is  the <<04833>>04745000
master operator. If neither condition is satisfied, CHECKALLOW <<04833>>04750000
returns FALSE.  DB must be at the stack.                       <<04833>>04755000
;                                                              <<04833>>04760000
                                                               <<04833>>04765000
LOGICAL PROCEDURE VERIFY'MASTEROP (LDEV);                      <<04833>>04770000
   VALUE LDEV;                                                 <<04833>>04775000
   INTEGER LDEV;                                               <<04833>>04780000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<04833>>04785000
COMMENT -- When a device has been ASSOCIATEd to  a  user,  the <<04833>>04790000
user  normally enters all commands (such as :REPLY) which per- <<04833>>04795000
tain to that device.  The master operator may also enter these <<04833>>04800000
commands, but since this is unusual,  VERIFY'MASTEROP  prompts <<04833>>04805000
the  operator  to  make  sure  s/he intends to use the command <<04833>>04810000
while the device is ASSOCIATEd.  The routine returns TRUE only <<04833>>04815000
if the user is the MASTEROP and s/he fails to  verify  his/her <<04833>>04820000
action.                                                        <<04833>>04825000
;                                                              <<04833>>04830000
                                                               <<04833>>04835000
LOGICAL PROCEDURE VERIFY'MASTOP'C (CLASSNAME);                 <<04833>>04840000
   INTEGER ARRAY CLASSNAME;                                    <<04833>>04845000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<04833>>04850000
COMMENT -- When a device class has been ASSOCIATEd to a  user, <<04833>>04855000
the  user  normally  enters  all commands (such as :STOPSPOOL) <<04833>>04860000
which pertain to that class.  The master operator may also en- <<04833>>04865000
ter these commands, but since this is unusual, VERIFY'MASTOP'C <<04833>>04870000
prompts the operator to make sure s/he intends to use the com- <<04833>>04875000
mand while the class is ASSOCIATEd.  The routine returns  TRUE <<04833>>04880000
only if the user is the MASTEROP and s/he fails to verify his/ <<04833>>04885000
her action.                                                    <<04833>>04890000
  The DCT SIR must be locked before calling VERIFY'MASTOP'C.   <<07438>>04895000
;                                                              <<04833>>04900000
                                                               <<04833>>04905000
INTEGER PROCEDURE VERIFY'RLDEV (PARM, LEN, ERRNUM, PARMNUM,    <<04833>>04910000
                                PARAMETERNUM);                 <<04833>>04915000
   VALUE LEN, PARAMETERNUM;                                    <<04833>>04920000
   INTEGER LEN, ERRNUM, PARMNUM, PARAMETERNUM;                 <<04833>>04925000
   BYTE ARRAY PARM;                                            <<04833>>04930000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<04833>>04935000
COMMENT -- VERIFY'RLDEV verifies that  the  ASCII  string  (of <<04833>>04940000
length  LEN) contained in PARM identifies a "real" (as opposed <<04833>>04945000
to virtual) device in this configuration of the operating sys- <<04833>>04950000
tem.  If so, the binary equivalent is returned in the  result, <<04833>>04955000
and the condition code is set to CCE.  If an error is detected <<04833>>04960000
ERRNUM is set to the CI error number, PARMNUM is set to PARAM- <<04833>>04965000
ETERNUM and the condition code is set to CCL.                  <<04833>>04970000
  DB must be at the stack.                                     <<04833>>04975000
;                                                              <<04833>>04980000
                                                               <<07438>>04985000
PROCEDURE DELINK'JMAT (JMAT'INDEX);                            <<07438>>04990000
   VALUE   JMAT'INDEX;                                         <<07438>>04995000
   INTEGER JMAT'INDEX;                                         <<07438>>05000000
   OPTION  PRIVILEGED, UNCALLABLE, EXTERNAL;                   <<07438>>05005000
COMMENT -- Delinks the JMAT subentry  starting  at  JMAT'INDEX <<07438>>05010000
from whichever queue it is on but does not alter the contents. <<07438>>05015000
The caller is expected to relink it or deallocate it, using  a <<07438>>05020000
call to an appropriate procedure.                              <<07438>>05025000
  JMAT'INDEX is a JMAT-relative offset, therefore DB  must  be <<07438>>05030000
at the JMAT and the JMAT SIR must be locked.                   <<07438>>05035000
;                                                              <<07438>>05040000
                                                                        05045000
PROCEDURE DELINKENTRY (CHAINP, ENTRYP);                                 05050000
   VALUE ENTRYP;                                                        05055000
   INTEGER POINTER CHAINP, ENTRYP;                                      05060000
   OPTION EXTERNAL;                                                     05065000
                                                                        05070000
PROCEDURE SROOSTER (DEVICE);                                            05075000
   VALUE DEVICE;                                                        05080000
   INTEGER DEVICE;                                                      05085000
   OPTION EXTERNAL;                                                     05090000
                                                                        05095000
INTEGER PROCEDURE FORMNAME(TYPE,TARGET,BA1,BA2,BA3,BA4);       <<02.EB>>05100000
   VALUE TYPE;INTEGER TYPE;                                    <<02.EB>>05105000
   BYTE ARRAY TARGET,BA1,BA2,BA3,BA4;                          <<02.EB>>05110000
   OPTION EXTERNAL;                                            <<02.EB>>05115000
                                                                        05120000
LOGICAL PROCEDURE SPOOLEDDEV (DEV);                                     05125000
   VALUE DEV;                                                           05130000
   INTEGER DEV;                                                         05135000
   OPTION EXTERNAL;                                                     05140000
                                                                        05145000
PROCEDURE SCHEDULEJOB' (JMATP);                                         05150000
   VALUE JMATP;                                                         05155000
   INTEGER POINTER JMATP;                                               05160000
   OPTION EXTERNAL;                                                     05165000
                                                                        05170000
PROCEDURE FREEDEVICE(DEV,WAIT,NOREW);                          <<TAPEL>>05175000
   VALUE DEV, WAIT;                                                     05180000
   INTEGER DEV;                                                         05185000
   LOGICAL WAIT,NOREW;                                         <<TAPEL>>05190000
   OPTION EXTERNAL,VARIABLE;                                   <<TAPEL>>05195000
                                                                        05200000
PROCEDURE SREMOVEXDD (XDDSUBP);                                         05205000
   VALUE XDDSUBP;                                                       05210000
   INTEGER POINTER XDDSUBP;                                             05215000
   OPTION EXTERNAL;                                                     05220000
                                                                        05225000
PROCEDURE AWAKE(PCBPT,N,WAITF);                                         05230000
   VALUE PCBPT,N,WAITF;                                                 05235000
   INTEGER PCBPT,N,WAITF;                                               05240000
   OPTION EXTERNAL;                                                     05245000
                                                                        05250000
LOGICAL PROCEDURE EXCHANGEDB(DSTX);                                     05255000
   VALUE DSTX;                                                          05260000
   LOGICAL DSTX;                                                        05265000
   OPTION EXTERNAL;                                                     05270000
                                                                        05275000
LOGICAL PROCEDURE GETSTACK (N,MP);                                      05280000
   VALUE N,MP;                                                          05285000
   LOGICAL N,MP;                                                        05290000
   OPTION EXTERNAL;                                                     05295000
                                                                        05300000
INTEGER PROCEDURE GETDEVINFO(DEVICE,DEVINFO);                           05305000
   BYTE ARRAY DEVICE;                                                   05310000
   INTEGER ARRAY DEVINFO;                                               05315000
   OPTION EXTERNAL;                                                     05320000
                                                               <<06915>>05325000
LOGICAL PROCEDURE PUTDEV(LDEV,TABLE,BUF);                      <<06915>>05330000
   VALUE   LDEV, TABLE;                                        <<06915>>05335000
   INTEGER LDEV, TABLE;                                        <<06915>>05340000
   INTEGER ARRAY BUF;                                          <<06915>>05345000
   OPTION  EXTERNAL;                                           <<06915>>05350000
                                                               <<06915>>05355000
LOGICAL PROCEDURE GETDEV(LDEV,TABLE,BUF);                      <<06915>>05360000
   VALUE   LDEV, TABLE;                                        <<06915>>05365000
   INTEGER LDEV, TABLE;                                        <<06915>>05370000
   INTEGER ARRAY BUF;                                          <<06915>>05375000
   OPTION  EXTERNAL;                                           <<06915>>05380000
                                                               <<06915>>05385000
LOGICAL PROCEDURE FBNDCHK(PARM,SIZE,UBND);                     <<06915>>05390000
   VALUE   PARM, SIZE, UBND;                                   <<06915>>05395000
   INTEGER PARM, SIZE, UBND;                                   <<06915>>05400000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<06915>>05405000
                                                                        05410000
LOGICAL PROCEDURE GETSIR(SIRNUM);                                       05415000
   VALUE SIRNUM;                                                        05420000
   INTEGER SIRNUM;                                                      05425000
   OPTION EXTERNAL;                                                     05430000
                                                                        05435000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,MASK,B,C,D,E,F,           <<0U.EB>>05440000
      DEST,REPLY,BUFF,DST,IOTYPE);                             <<0U.EB>>05445000
   VALUE SETNO,MSGNO,MASK,B,C,D,E,F,DEST,REPLY,BUFF,           <<0U.EB>>05450000
      DST,IOTYPE;                                              <<0U.EB>>05455000
   LOGICAL SETNO,MSGNO,MASK,B,C,D,E,F,DEST,REPLY,BUFF,         <<0U.EB>>05460000
      DST,IOTYPE;                                              <<0U.EB>>05465000
   OPTION VARIABLE,EXTERNAL;                                   <<0U.EB>>05470000
                                                                        05475000
PROCEDURE RELSIR(SIRNUM,ALREADY);                                       05480000
   VALUE SIRNUM,ALREADY;                                                05485000
   INTEGER SIRNUM;                                                      05490000
   LOGICAL ALREADY;                                                     05495000
   OPTION EXTERNAL;                                                     05500000
                                                                        05505000
PROCEDURE SUDDENDEATH(ERRNUM);                                          05510000
   VALUE ERRNUM;                                                        05515000
   INTEGER ERRNUM;                                                      05520000
   OPTION EXTERNAL;                                                     05525000
                                                                        05530000
PROCEDURE PROCREATE (PIN, PLABEL, DELTAP, STACKDST, GLOBSIZE,  <<01200>>05535000
                     DLSIZE, LOCSIZE, PRI, STRING, STRINGLNTH, <<01200>>05540000
                     PARM, FLAGS, MAXSTACK, STDIN, STDLIST);   <<01200>>05545000
  VALUE PLABEL, DELTAP, STACKDST, GLOBSIZE, DLSIZE, LOCSIZE,   <<01200>>05550000
        PRI, STRING, STRINGLNTH, PARM, FLAGS, MAXSTACK;        <<01200>>05555000
  INTEGER PLABEL, DELTAP, STACKDST, GLOBSIZE, DLSIZE, LOCSIZE, <<01200>>05560000
          PRI, STRING, STRINGLNTH, PARM, PIN, MAXSTACK;        <<01200>>05565000
  LOGICAL FLAGS;                                               <<01200>>05570000
  LOGICAL ARRAY STDIN, STDLIST;                                <<01200>>05575000
  OPTION EXTERNAL;                                             <<01200>>05580000
                                                                        05585000
LOGICAL PROCEDURE SETCRITICAL;                                          05590000
OPTION EXTERNAL;                                                        05595000
                                                                        05600000
PROCEDURE RESETCRITICAL(CRSTATE);                                       05605000
VALUE CRSTATE;                                                          05610000
LOGICAL CRSTATE;                                                        05615000
OPTION EXTERNAL;                                                        05620000
                                                               <<S8948>>05625000
PROCEDURE TIMEPARMS(STRING,TIME,ERROR,PRINTERROR);             <<S8948>>05630000
VALUE PRINTERROR;                                              <<S8948>>05635000
LOGICAL PRINTERROR;                                            <<S8948>>05640000
BYTE ARRAY STRING;                                             <<S8948>>05645000
LOGICAL ARRAY TIME;                                            <<S8948>>05650000
INTEGER ERROR;                                                 <<S8948>>05655000
OPTION EXTERNAL;                                               <<S8948>>05660000
                                                                        05665000
LOGICAL PROCEDURE SENDSPOOLERMSG(LDEV,DIRECTIVE,SPOOFLING,     <<00552>>05670000
        SPOOLINFO,                                             <<01549>>05675000
        ERRNUM,PARMNUM);                                       <<00552>>05680000
   VALUE LDEV,DIRECTIVE,SPOOFLING;                             <<00552>>05685000
   INTEGER DIRECTIVE,ERRNUM,PARMNUM;                           <<00552>>05690000
   LOGICAL LDEV,SPOOFLING;                                     <<00552>>05695000
   LOGICAL ARRAY SPOOLINFO;                                    <<01549>>05700000
   OPTION FORWARD;                                             <<04833>>05705000
                                                               <<00552>>05710000
PROCEDURE NRJEOPENQS;                                          <<06915>>05715000
   OPTION PRIVILEGED, UNCALLABLE, FORWARD;                     <<06915>>05720000
                                                               <<06915>>05725000
INTEGER PROCEDURE ADOPT(ADOPTEE,ADOPTOR);                      <<00552>>05730000
   VALUE ADOPTEE,ADOPTOR;                                      <<00552>>05735000
   INTEGER ADOPTEE,ADOPTOR;                                    <<00552>>05740000
   OPTION EXTERNAL;                                            <<00552>>05745000
                                                               <<00552>>05750000
LOGICAL PROCEDURE SFINDIDD(DFID,XDDEP);                        <<04833>>05755000
   VALUE DFID;                                                 <<04833>>05760000
   INTEGER XDDEP;                                              <<04833>>05765000
   INTEGER DFID;                                               <<04833>>05770000
   OPTION EXTERNAL;                                            <<04833>>05775000
                                                               <<04833>>05780000
LOGICAL PROCEDURE SFINDACTIVE(LDEV,DFID);                      <<04833>>05785000
   VALUE LDEV;                                                 <<04833>>05790000
   INTEGER LDEV,DFID;                                          <<04833>>05795000
   OPTION EXTERNAL;                                            <<04833>>05800000
                                                                        05805000
PROCEDURE CIERR(ERRNUM, ERRADR, PARMMASK, PARM);               <<U.RAO>>05810000
   VALUE ERRNUM, PARMMASK, PARM;                               <<U.RAO>>05815000
   INTEGER ERRNUM, PARMMASK, PARM;                             <<U.RAO>>05820000
   BYTE ARRAY ERRADR;                                          <<U.RAO>>05825000
   OPTION PRIVILEGED, UNCALLABLE, VARIABLE, EXTERNAL;          <<U.RAO>>05830000
                                                               <<U.RAO>>05835000
PROCEDURE FERROR'(FNUM, PARMNUM);                              <<U.RAO>>05840000
   VALUE FNUM;                                                 <<U.RAO>>05845000
   INTEGER FNUM, PARMNUM;                                      <<U.RAO>>05850000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<U.RAO>>05855000
                                                               <<U.RAO>>05860000
INTEGER PROCEDURE CHECKFILENAME'(PDEF,GPTR,APTR,ERRPTR);       <<U.RAO>>05865000
VALUE PDEF;                                                    <<U.RAO>>05870000
DOUBLE PDEF;                                                   <<U.RAO>>05875000
LOGICAL APTR, <<POINTER TO ACCOUNT PART OF NAME>>              <<U.RAO>>05880000
        GPTR, <<POINTER TO GROUP PART OF NAME>>                <<U.RAO>>05885000
        ERRPTR;  <<POINTER TO PLACE IN NAME OF ERROR>>         <<U.RAO>>05890000
OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                       <<U.RAO>>05895000
                                                               <<U.RAO>>05900000
INTEGER PROCEDURE FSOPEN(FDESG,FOPT,AOPT,XDDX,DEV,FMSG,                 05905000
      ULAB,BF,NB,FS,NE,IA,FC);                                          05910000
   VALUE FOPT,AOPT,XDDX,ULAB,BF,NB,FS,NE,IA,FC;                         05915000
   INTEGER XDDX,ULAB,BF,NB,NE,IA,FC;                                    05920000
   LOGICAL FOPT,AOPT;                                                   05925000
   DOUBLE FS;                                                           05930000
   BYTE ARRAY FDESG,DEV,FMSG;                                           05935000
   OPTION EXTERNAL,VARIABLE;  <<FOPEN SEC ENTRY POINT>>                 05940000
                                                               <<06915>>05945000
INTEGER PROCEDURE GET'DSDEVICE(DEV);                           <<01906>>05950000
VALUE DEV;                                                     <<01906>>05955000
INTEGER DEV;                                                   <<01906>>05960000
OPTION EXTERNAL;                                               <<01906>>05965000
                                                               <<06915>>05970000
LOGICAL PROCEDURE GETCLASS(BUF,FLAG,CLADR,CLINX,CLNAME);       <<01906>>05975000
VALUE FLAG,CLADR,CLINX;                                        <<01906>>05980000
LOGICAL FLAG;                                                  <<01906>>05985000
INTEGER CLADR,CLINX;                                           <<01906>>05990000
INTEGER ARRAY CLNAME,BUF;                                      <<01906>>05995000
OPTION VARIABLE,EXTERNAL;                                      <<01906>>06000000
                                                                        06005000
PROCEDURE FSCLOSE(FN,DISP,SEC);                                         06010000
   VALUE   FN,DISP,SEC;                                                 06015000
   INTEGER FN,DISP,SEC;                                                 06020000
   OPTION  EXTERNAL;  <<FCLOSE SEC ENTRY POINT>>                        06025000
                                                               <<00534>>06030000
PROCEDURE FRESETEOF;                                           <<00534>>06035000
   OPTION PRIVILEGED,UNCALLABLE,EXTERNAL;                      <<00534>>06040000
                                                               <<00534>>06045000
LOGICAL PROCEDURE MASTEROP; OPTION EXTERNAL;                   <<00552>>06050000
                                                               <<00552>>06055000
PROCEDURE SRELINKODD (ODD'ENTRY'POINT, DEV'OR'CLASS);          <<06126>>06060000
   VALUE ODD'ENTRY'POINT, DEV'OR'CLASS;                        <<06126>>06065000
   INTEGER DEV'OR'CLASS;                                       <<06126>>06070000
   INTEGER POINTER ODD'ENTRY'POINT;                            <<06126>>06075000
  COMMENT -- Relinks ODD subentry at  ODD'ENTRY'POINT  to  the <<06126>>06080000
device  class (DCT index, <0) or logical device (>0) specified <<06126>>06085000
in DEV'OR'CLASS.                                               <<07438>>06090000
;                                                              <<06126>>06095000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<06126>>06100000
                                                               <<00610>>06105000
LOGICAL PROCEDURE SFINDODD(DFID,XDDEP);                        <<00858>>06110000
   VALUE DFID;                                                 <<00858>>06115000
   INTEGER XDDEP;                                              <<00858>>06120000
   INTEGER DFID;                                               <<00858>>06125000
   OPTION EXTERNAL;                                            <<00858>>06130000
                                                               <<00858>>06135000
                                                                        06140000
PROCEDURE HELP;                                                <<00170>>06145000
   OPTION EXTERNAL;                                            <<00170>>06150000
                                                               <<07438>>06155000
                                                               <<07438>>06160000
INTEGER PROCEDURE XRETJTENTRY (N1,N2,N3,SIZE,INFO);            <<01884>>06165000
   INTEGER SIZE;                                               <<01884>>06170000
   INTEGER ARRAY INFO;                                         <<01884>>06175000
   BYTE ARRAY N1,N2,N3;                                        <<01884>>06180000
   OPTION EXTERNAL;                                            <<01884>>06185000
INTEGER PROCEDURE PARSE'DEV'PARMS(BYTE'STRING,DEVPARMS);       <<01884>>06190000
   BYTE ARRAY BYTE'STRING;                                     <<01884>>06195000
   LOGICAL ARRAY DEVPARMS;                                     <<01884>>06200000
   OPTION EXTERNAL;                                            <<01884>>06205000
                                                               <<04859>>06210000
LOGICAL PROCEDURE FINDJOB( JMENT, ENTP, JNUM, JOB, JNAME,      <<04859>>06215000
                           UNAME, ANAME, SIR );                <<04859>>06220000
   VALUE JNUM, JOB;                                            <<04859>>06225000
   INTEGER ARRAY JMENT, JNAME, UNAME, ANAME;                   <<04859>>06230000
   INTEGER JNUM, SIR, ENTP;                                    <<04859>>06235000
   LOGICAL JOB;                                                <<04859>>06240000
OPTION VARIABLE, EXTERNAL;                                     <<04859>>06245000
                                                               <<04859>>06250000
                                                               <<01884>>06255000
   LOGICAL PROCEDURE GET'DEV'PARM(TOKEN, DEVPARMS, INDEX);     <<01884>>06260000
      VALUE TOKEN;                                             <<01884>>06265000
      LOGICAL TOKEN;                                           <<01884>>06270000
      LOGICAL ARRAY DEVPARMS;                                  <<01884>>06275000
      INTEGER INDEX;                                           <<01884>>06280000
      OPTION EXTERNAL;                                         <<01884>>06285000
                                                               <<W7675>>06290000
DOUBLE PROCEDURE DOUBLETIME;                                   <<W7675>>06295000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<W7675>>06300000
COMMENT -- Returns current time in the following  (doubleword) <<W7675>>06305000
format:                                                        <<W7675>>06310000
  [1/0, 7/year, 9/day, 5/hour, 6/minute, 4/quadseconds] D      <<W7675>>06315000
;                                                              <<W7675>>06320000
                                                               <<04833>>06325000
LOGICAL PROCEDURE CHECKASS (LDEV, ASSENT);                     <<04833>>06330000
  VALUE LDEV;                                                  <<04833>>06335000
  LOGICAL LDEV;                                                <<04833>>06340000
  INTEGER ARRAY ASSENT;                                        <<04833>>06345000
  OPTION PRIVILEGED, UNCALLABLE, VARIABLE, EXTERNAL;           <<04833>>06350000
COMMENT -- CHECKASS checks if the user has  ASSOCIATEd  device <<04833>>06355000
LDEV.  If  so, it returns TRUE, else it returns FALSE.  If AS- <<04833>>06360000
SENT is specified, the Associate Table assent is returned, re- <<04833>>06365000
gardless of whether CHECKASS returns TRUE or FALSE.            <<04833>>06370000
;                                                              <<04833>>06375000
                                                               <<07063>>06380000
PROCEDURE WRITEDSEG (DATA'SEG);                                <<07063>>06385000
   VALUE   DATA'SEG;                                           <<07063>>06390000
   INTEGER DATA'SEG;                                           <<07063>>06395000
   OPTION  PRIVILEGED, UNCALLABLE, EXTERNAL;                   <<07063>>06400000
COMMENT -- Posts the specified data segment to the disc.       <<07063>>06405000
;                                                              <<07063>>06410000
                                                               <<04833>>06415000
PROCEDURE LOGIMAGE (TYPE, PARMSP);                             <<04833>>06420000
  VALUE TYPE;                                                  <<04833>>06425000
  INTEGER TYPE;                                                <<04833>>06430000
  BYTE ARRAY PARMSP;                                           <<04833>>06435000
  OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                     <<04833>>06440000
COMMENT -- Logs operator commands in the system log file.      <<04833>>06445000
;                                                              <<04833>>06450000
INTEGER PROCEDURE GET'SPECIFIC'DISC'SPACE(LDEV,                <<07063>>06455000
                         DISC'ADDRESS,NUMBER'OF'SECTORS);      <<07063>>06460000
   VALUE LDEV,DISC'ADDRESS,NUMBER'OF'SECTORS;                  <<07063>>06465000
   INTEGER LDEV;                                               <<07063>>06470000
   DOUBLE DISC'ADDRESS,NUMBER'OF'SECTORS;                      <<07063>>06475000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<07063>>06480000
                                                               <<07063>>06485000
PROCEDURE RETURN'DISC'SPACE(LDEV,DISC'ADDRESS,                 <<07063>>06490000
                                     NUMBER'OF'SECTORS);       <<07063>>06495000
   VALUE LDEV,DISC'ADDRESS,NUMBER'OF'SECTORS;                  <<07063>>06500000
   INTEGER LDEV;                                               <<07063>>06505000
   DOUBLE DISC'ADDRESS,NUMBER'OF'SECTORS;                      <<07063>>06510000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<07063>>06515000
                                                               <<07063>>06520000
DOUBLE PROCEDURE ATTACHIO(LDEV,QMISC,DSTX,ADDR,FUNC,CNT,       <<07063>>06525000
                            P1,P2,FLAGS);                      <<07063>>06530000
   VALUE LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS;            <<07063>>06535000
   INTEGER LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS;          <<07063>>06540000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<07063>>06545000
                                                               <<07063>>06550000
INTEGER PROCEDURE LUN(VTAB'INDEX,MVTAB'INDEX);                 <<07063>>06555000
   VALUE VTAB'INDEX,MVTAB'INDEX;                               <<07063>>06560000
   INTEGER VTAB'INDEX,MVTAB'INDEX;                             <<07063>>06565000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<07063>>06570000
COMMENT -- Given a system volume table index (VTAB'INDEX), re- <<07063>>06575000
turns the corresponding LDEV number.  If MVTAB'INDEX <> 0, the <<07063>>06580000
request is for a private volume set.  The Mounted Volume Table <<07063>>06585000
is examined and its corresponding LDEV is returned.            <<07063>>06590000
;                                                              <<07063>>06595000
                                                               <<02548>>06600000
INTEGER PROCEDURE GET'DEVICE'CLASS (CLASS'INDEX,               <<07438>>06605000
                      ENTRY'ADDRESS);                          <<07438>>06610000
   VALUE   CLASS'INDEX;                                        <<07438>>06615000
   INTEGER CLASS'INDEX, ENTRY'ADDRESS;                         <<07438>>06620000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<07438>>06625000
COMMENT --                                                     <<07438>>06630000
  GET'DEVICE'CLASS accepts a Device Class Table index and  re- <<07438>>06635000
turns the length of its entry in the DCT and its segment-rela- <<07438>>06640000
tive offset in the DCT.  Callers can use this  information  to <<07438>>06645000
create a local copy of the entry.  New code should prefer this <<07438>>06650000
procedure over GETCLASS because it relies only on the $INCLUDE <<07438>>06655000
files for its information.  We still use  GETCLASS  here,  but <<07438>>06660000
only to obtain ENTRY'ADDRESS (the first word it returns).      <<07438>>06665000
                                                               <<07438>>06670000
    *-*-*  THIS IS NOT A REPLACEMENT FOR GETCLASS.   *-*-*     <<07438>>06675000
                                                               <<07438>>06680000
Inputs:   CLASS'INDEX.  The Nth entry (1 is first) in the  De- <<07438>>06685000
          vice Class Table.  Must be > 0.                      <<07438>>06690000
                                                               <<07438>>06695000
Returns:  Result.  The length of the entry, or -1 if the entry <<07438>>06700000
          doesn't exist.                                       <<07438>>06705000
                                                               <<07438>>06710000
          ENTRY'ADDRESS.  The DCT segment-relative address  of <<07438>>06715000
          the entry, or 0 if the entry doesn't exist.          <<07438>>06720000
                                                               <<07438>>06725000
Special considerations:  DB must be at  the  stack  on  entry, <<07438>>06730000
                         same at exit.  This is because of the <<07438>>06735000
                         stack DB-relative reference parameter <<07438>>06740000
                         ENTRY'ADDRESS.                        <<07438>>06745000
;                                                              <<07438>>06750000
                                                               <<07438>>06755000
PROCEDURE SYSINTERR (ERRORNUM, BACK);                          <<F7898>>06760000
   VALUE   ERRORNUM, BACK;                                     <<F7898>>06765000
   INTEGER ERRORNUM, BACK;                                     <<F7898>>06770000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<F7898>>06775000
COMMENT -- Prints msg ERRORNUM in system internal  error  set. <<F7898>>06780000
If BACK >= -1, also prints Status and Delta-P of stack marker. <<F7898>>06785000
;                                                              <<F7898>>06790000
                                                               <<F7898>>06795000
INTRINSIC FOPEN,FREAD,FWRITE,FCONTROL,FCLOSE, FDEVICECONTROL;  <<06066>>06800000
INTRINSIC FFILEINFO, FGETINFO,FCHECK,FPOINT;                   <<F9095>>06805000
INTRINSIC ASCII,BINARY,DASCII,ZSIZE,DLSIZE,PRINT;                       06810000
INTRINSIC SEARCH,MYCOMMAND;                                             06815000
INTRINSIC READX;                                               <<04833>>06820000
INTRINSIC GETDSEG,FREEDSEG;                                    <<00548>>06825000
INTRINSIC FREADDIR;                                            <<01549>>06830000
$PAGE "   ***   =SPOOL STUFF   ***"                                     06835000
                                                                        06840000
                                                                        06845000
LOGICAL PROCEDURE VALIDSPOOLEE (DEVTYPE, OUT);                          06850000
   VALUE DEVTYPE, OUT;                                                  06855000
   INTEGER DEVTYPE;                                                     06860000
   LOGICAL OUT;                                                         06865000
   OPTION PRIVILEGED, UNCALLABLE;                                       06870000
BEGIN                                                                   06875000
<< PERMISSABLE SPOOLEES.  CORRESPONDING DEVTYPE BITS.  ON => SPOOLEE >> 06880000
   LOGICAL ARRAY     OUTMASK (*) = PB :=                                06885000
                        [8/0, 8/0],                                     06890000
                      [8/%(2) 00001010, 8/0], <<     PRP,MRJE>><<00763>>06895000
                        [8/%(2) 11011110, 8/0];<<LP,CDPN,PLTS>><<00.06>>06900000
   LOGICAL ARRAY     INMASK (*) = PB :=                                 06905000
                        [8/0, 8/%(2) 10000000],  <<CD RDR>>             06910000
                        [8/%(2) 00001000, 8/%(2) 10000000],             06915000
                        <<PRNTR/RDR/PUN, MAG TAPE>>                     06920000
                        [8/0, 8/0];                                     06925000
                                                                        06930000
<< >>                                                                   06935000
   XREG := DEVTYPE &LSR(4);                                             06940000
   TOS := IF OUT THEN OUTMASK (XREG) ELSE INMASK (XREG);                06945000
   XREG := DEVTYPE.(12:4);                                              06950000
   ASSEMBLE (CSL 1, X);                                                 06955000
   VALIDSPOOLEE := TOS;                                                 06960000
   END;    <<VALIDSPOOLEE>>                                             06965000
$PAGE "IT'S'A'DISC"                                            <<04833>>06970000
LOGICAL PROCEDURE IT'S'A'DISC (TYPE);                          <<04833>>06975000
                                                               <<03531>>06980000
VALUE TYPE;                                                    <<03531>>06985000
INTEGER TYPE;   << Input is a device type. >>                  <<03531>>06990000
OPTION PRIVILEGED, UNCALLABLE;                                 <<U7867>>06995000
                                                               <<03531>>07000000
BEGIN                                                          <<03531>>07005000
                                                               <<03531>>07010000
   << This logical procedure determines whether a   >>         <<03531>>07015000
   << given device type is a valid disc device type >>         <<03531>>07020000
                                                               <<03531>>07025000
EQUATE                                                         <<03531>>07030000
   MIN'DISC'TYPE = 0,                                          <<03531>>07035000
   MAX'DISC'TYPE = 6;                                          <<03531>>07040000
                                                               <<03531>>07045000
IT'S'A'DISC := MIN'DISC'TYPE <= TYPE <= MAX'DISC'TYPE;         <<04833>>07050000
                                                               <<03531>>07055000
END; << IT'S'A'DISC >>                                         <<04833>>07060000
                                                               <<03531>>07065000
                                                                        07070000
$PAGE "INITIATESPOOLER"                                        <<04833>>07075000
INTEGER PROCEDURE INITIATESPOOLER (DEVICE, OUT);                        07080000
   VALUE DEVICE, OUT;                                                   07085000
   INTEGER DEVICE;                                                      07090000
   LOGICAL OUT;                                                         07095000
   OPTION PRIVILEGED, UNCALLABLE;                                       07100000
BEGIN                                                                   07105000
  COMMENT -- INITIATESPOOLER creates a spooler process for DE- <<07438>>07110000
VICE (if it's available and spoolable), adopts the process  to <<07438>>07115000
become a son of PROGEN, and wakes it up. The spooler is an in- <<07438>>07120000
put or output spooler, depending on the value of OUT (0 =  in, <<07438>>07125000
1  = out).  If out, bit 14 also causes the device spool queues <<07438>>07130000
to be opened if it is set.                                     <<07438>>07135000
  There are an amazing number of functional returns, which are <<07438>>07140000
all reasonably self-documenting.                               <<07438>>07145000
                                                               <<07438>>07150000
                     *-*-*-*  NOTE:  *-*-*-*                   <<07438>>07155000
                                                               <<07438>>07160000
  DB must be at the stack on entry.  There is  not  enough  Q+ <<07438>>07165000
space  to  hold  the  direct arrays required to support split- <<07438>>07170000
stack calls.                                                   <<07438>>07175000
;                                                              <<07438>>07180000
   DEFINE            SPOOFLING = OUT.(14:1) #;                          07185000
   EQUATE                              <<RETURNS>>                      07190000
                     XOKAY  = 0,                                        07195000
                     XOWNEDOUT  = -2,                                   07200000
                     XOWNEDIN  = -1,                                    07205000
                     XOWNED  = 1,                                       07210000
                     XNOTREALDEV  = 2,                                  07215000
                     XNOTSPOOLEE  = 3,                                  07220000
                     XNOTJD  = 4,                                       07225000
                     XDIAG  = 5,                                        07230000
                     XNOSEG  = 6,                                       07235000
                     XCANTPROC = 7,                            <<00552>>07240000
                     XBUSY = 8,                                <<01200>>07245000
                     XDEV'DOWN = 9,                            <<02611>>07250000
                     NOSTRING = 0,         << FOR PROCREATE >> <<01200>>07255000
                     NOSTLEN = 0,                              <<01200>>07260000
                     PRIVAL = [5/4,3/0,8/SPOOLPRI];            <<01200>>07265000
<< LOCALS >>                                                            07270000
   LOGICAL ARRAY     LDT(0:SIZE'OF'LDT'ENTRY - 1),             <<07438>>07275000
                     PXGLOB(0:PXG'SIZE - 1),                   <<07438>>07280000
                     QARRAY(*) = Q + 0,  << Reqd by INCLPXG >> <<07438>>07285000
                     ZERO(0:GLOBSIZE-1);                       <<07438>>07290000
   INTEGER           PCBGLOBLOC,    << Required by INCLPXG. >> <<07438>>07295000
                     SAVE'LDT'SIR,                             <<07438>>07300000
                     INIT'DIRECTIVE := INITDIRECTIVE,          <<07438>>07305000
                     MAXSTACKSIZE,                                      07310000
                     SPSTACK,                                           07315000
                     SPPIN  := 0;                                       07320000
   INTEGER           LDT'INDEX := 0;                           <<07438>>07325000
   INTEGER           LPDT'INDEX ;                              <<06744>>07330000
   LOGICAL                                                     <<07438>>07335000
                     SQREVERSED  := FALSE,                              07340000
                     UNWIND := FALSE,                          <<01200>>07345000
                     NOSTDIN := 0,         << FOR PROCREATE >> <<01200>>07350000
                     NOSTDLIST := 0,                           <<07438>>07355000
                     EXT'PLBL,                                 <<07438>>07360000
                     INT'PLBL;                                 <<07438>>07365000
                                                               <<07438>>07370000
LOGICAL POINTER      DB'OFFSET;   << To init. spooler stack >> <<07438>>07375000
                                                                        07380000
                                                               <<07438>>07385000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07438>>07390000
SUBROUTINE DEF'MOVETODSEG;                                     <<07438>>07395000
<< >>                                                                   07400000
LPDT'INDEX := DEVICE * INTEGER (LPDT'ENTRY'SIZE);              <<07438>>07405000
ZERO := 0;                                                     <<07438>>07410000
MOVE ZERO(1) := ZERO, (GLOBSIZE - 1);                          <<07438>>07415000
SAVE'LDT'SIR := GETSIR (LDT'SIR);                              <<07438>>07420000
IF (1 <= DEVICE <= INTEGER (LPDT'MAX'ENTRIES)) AND             <<07438>>07425000
   NOT LPDT'VIRTUAL'DEVICE THEN                                <<07438>>07430000
   BEGIN   << Valid real device.                            >> <<07438>>07435000
   MOVEFROMDSEG (LDT, LDT'DST, DEVICE * SIZE'OF'LDT'ENTRY,     <<07438>>07440000
                 SIZE'OF'LDT'ENTRY);                           <<07438>>07445000
   IF VALIDSPOOLEE (LDT'DEVICE'TYPE, OUT) THEN                 <<07438>>07450000
      IF NOT LDT'AVAIL'TO'DIAG THEN                            <<07438>>07455000
         IF (LDT'AVAIL'TO'SYS) THEN                            <<06744>>07460000
            BEGIN   << Device is UP.                        >> <<07438>>07465000
            IF OUT OR LPDT'DATA'ACCEPT OR LPDT'JOB'ACCEPT THEN <<06744>>07470000
               BEGIN  << Job and/or Data Accepting if input >> <<07438>>07475000
               DISABLE;                                                 07480000
               IF LPDT'DEV'OWN'STATE = LPDT'NOT'OWNED THEN     <<06744>>07485000
                  BEGIN    <<UNOWNED: RESERVE>>                         07490000
                  LPDT'DEV'OWN'STATE := LPDT'RESERVED;         <<06744>>07495000
                  ENABLE;                                               07500000
                  IF OUT THEN                                           07505000
                     BEGIN    <<SET SPOOFLING ALSO>>                    07510000
                     IF LDT'SPOOL'QUEUES <> SPOOFLING THEN     <<06744>>07515000
                        BEGIN                                           07520000
                        LDT'SPOOL'QUEUES := SPOOFLING;         <<06744>>07525000
                        SQREVERSED := TRUE;                             07530000
                        END;                                            07535000
                     LDT'SPOOL'STATE := LDT'OUTPUT'SPOOLED;    <<07438>>07540000
                     END      << Set SPOOFLING also.        >> <<07438>>07545000
                  ELSE                                                  07550000
                     LDT'SPOOL'STATE := LDT'INPUT'SPOOLED;     <<07438>>07555000
                  UNWIND := TRUE;                                       07560000
                                                               <<07438>>07565000
<< The following monstrosity was preserved from MPE4.       >> <<07438>>07570000
                                                               <<07438>>07575000
                  MAXSTACKSIZE := ((INITSTACKSIZE+127)&ASR(7)) <<07438>>07580000
                     & ASL(7) + 512 * (BLOCKS + 2);            <<07438>>07585000
                  IF (SPSTACK := GETSTACK (INITSTACKSIZE,               07590000
                                 MAXSTACKSIZE)) <> 0 THEN      <<07438>>07595000
                     BEGIN   << Got stack, create spooler.  >> <<07438>>07600000
                     IF OUT THEN                               <<07438>>07605000
                        BEGIN                                  <<07438>>07610000
                        EXT'PLBL := SYSSPLOUTEXTPLBL.(8:8);    <<07438>>07615000
                        INT'PLBL := SYSSPLOUTINTPLBL;          <<07438>>07620000
                        END                                    <<07438>>07625000
                     ELSE                                      <<07438>>07630000
                        BEGIN                                  <<07438>>07635000
                        EXT'PLBL := SYSSPLINEXTPLBL.(8:8);     <<07438>>07640000
                        INT'PLBL := SYSSPLININTPLBL;           <<07438>>07645000
                        END;                                   <<07438>>07650000
                     EXT'PLBL.(0:1) := 1;                      <<07438>>07655000
                     PROCREATE (SPPIN, EXT'PLBL, INT'PLBL,     <<07438>>07660000
                                SPSTACK, GLOBSIZE + 30, 0,     <<07438>>07665000
                                LOCSIZE, PRIVAL, NOSTRING,     <<01200>>07670000
                                NOSTLEN, 0, %713, MAXSTACKSIZE,<<01200>>07675000
                                NOSTDIN, NOSTDLIST);           <<01200>>07680000
                     IF = THEN                                          07685000
                        BEGIN  << Adopt to PROGEN and AWAKE >> <<07438>>07690000
                        ADOPT (SPPIN, 3);                      <<07438>>07695000
                                                               <<07438>>07700000
<< Fetch DB offset in spooler stack so we can zero it out.  >> <<07438>>07705000
                                                               <<07438>>07710000
                        MOVEFROMDSEG (PXGLOB, SPSTACK, 0,      <<07438>>07715000
                                      PXG'SIZE);               <<07438>>07720000
                        PCBGLOBLOC := @PXGLOB - @QARRAY;       <<07438>>07725000
                        @DB'OFFSET := PXG'RELATIVE'DB;         <<07438>>07730000
                        MOVETODSEG (SPSTACK, @DB'OFFSET, ZERO, <<07438>>07735000
                                    GLOBSIZE);                 <<07438>>07740000
                        MOVETODSEG (SPSTACK,                   <<07438>>07745000
                                    @DB'OFFSET(DIRECTIV),      <<07438>>07750000
                                    INIT'DIRECTIVE, 1);        <<07438>>07755000
                        MOVETODSEG (SPSTACK,                   <<07438>>07760000
                                    @DB'OFFSET(SPOOLE),        <<07438>>07765000
                                    DEVICE, 1);                <<07438>>07770000
                        AWAKE (SPPIN * PCBSIZE, DADWAIT, 0);   <<07438>>07775000
                        TOS := XOKAY;                                   07780000
                        MOVETODSEG (LDT'DST, DEVICE *          <<07438>>07785000
                           SIZE'OF'LDT'ENTRY, LDT,             <<07438>>07790000
                           SIZE'OF'LDT'ENTRY);                 <<07438>>07795000
                        END    << Adopt to PROGEN and AWAKE >> <<07438>>07800000
                     ELSE                                      <<07438>>07805000
                        TOS := XCANTPROC;                      <<07438>>07810000
                     END     << Got stack, create spooler.  >> <<07438>>07815000
                  ELSE                                         <<07438>>07820000
                     TOS := XNOSEG;                            <<07438>>07825000
                  END      << Unowned, reserve.             >> <<07438>>07830000
               ELSE                                                     07835000
                  BEGIN   << Owned by somebody.             >> <<07438>>07840000
                  ENABLE;   << D'ye remember our DISABLE?   >> <<07438>>07845000
                  IF LDT'SPOOL'STATE = LDT'NOT'SPOOLED THEN    <<06744>>07850000
                     TOS := XOWNED  << Owned by non-spooler >> <<07438>>07855000
                  ELSE                                                  07860000
                     IF LDT'SPOOL'STATE = LDT'OUTPUT'SPOOLED   <<07438>>07865000
                        THEN TOS := XOWNEDOUT                  <<07438>>07870000
                     ELSE                                               07875000
                        TOS := XOWNEDIN;                       <<07438>>07880000
                  END     << Owned by somebody.             >> <<07438>>07885000
               END    << Job and/or Data Accepting if input >> <<07438>>07890000
            ELSE                                               <<07438>>07895000
               TOS := XNOTJD                                   <<07438>>07900000
            END     << Device is UP.                        >> <<07438>>07905000
         ELSE                                                  <<07438>>07910000
            TOS := XDEV'DOWN                                   <<07438>>07915000
      ELSE                                                     <<07438>>07920000
         TOS := XDIAG                                          <<07438>>07925000
   ELSE                                                        <<07438>>07930000
      TOS := XNOTSPOOLEE;                                      <<07438>>07935000
   END     << Valid real device.                            >> <<07438>>07940000
ELSE                                                           <<07438>>07945000
   TOS := XNOTREALDEV;                                         <<07438>>07950000
                                                                        07955000
IF ((INITIATESPOOLER := TOS) <> XOKAY)  AND  UNWIND  THEN      <<07438>>07960000
   BEGIN   << Error after changing LDT, change it back.     >> <<07438>>07965000
   LDT'SPOOL'STATE := LDT'NOT'SPOOLED;                         <<07438>>07970000
   IF SQREVERSED THEN LDT'SPOOL'QUEUES := NOT SPOOFLING;       <<07438>>07975000
   DISABLE;                                                    <<07438>>07980000
   LPDT'DEV'OWN'STATE := LPDT'NOT'OWNED;                       <<07438>>07985000
   ENABLE;                                                     <<07438>>07990000
   MOVETODSEG (LDT'DST, DEVICE * SIZE'OF'LDT'ENTRY, LDT,       <<07438>>07995000
               SIZE'OF'LDT'ENTRY);                             <<07438>>08000000
   END;    << Error after changing LDT, change it back.     >> <<07438>>08005000
                                                                        08010000
RELSIR (LDT'SIR, SAVE'LDT'SIR);                                <<07438>>08015000
                                                                        08020000
RETURN;                                                                 08025000
HELP;   << For STT entry -- never executed.                 >> <<07438>>08030000
END;    << of INITIATESPOOLER.                              >> <<07438>>08035000
$PAGE "CONSSPOOL"                                              <<07438>>08040000
$CONTROL SEGMENT = SPOOLCOMS1                                  <<07438>>08045000
                                                                        08050000
LOGICAL PROCEDURE CONSSPOOL (PARMSTRING);                               08055000
   BYTE ARRAY PARMSTRING;                                               08060000
   OPTION PRIVILEGED, UNCALLABLE;                                       08065000
BEGIN                                                                   08070000
                                                                        08075000
   LOGICAL RESULT = CONSSPOOL;                                          08080000
                                                                        08085000
<< MYCOMMAND AND PARSING VARIABLES >>                                   08090000
   INTEGER           X1 := %26015,     <<COMMA, CR>>                    08095000
                     NUMPARMS;                                          08100000
   BYTE ARRAY        DELIM (*) = X1;                                    08105000
   DOUBLE ARRAY      PARMS (0:3) = Q;                                   08110000
   INTEGER           PNUM := 1;        <<POSITIONED FOR 1ST KEYWORD>>   08115000
                                                                        08120000
<< KEYWORD DEFINITIONS >>                                               08125000
   EQUATE            DICTLEN = 38,                                      08130000
                     X2 = DICTLEN -1;                                   08135000
   BYTE ARRAY        KEYWORDSP (*) = PB :=                              08140000
                        10, 8, "STARTOUT",                              08145000
                        9, 7, "STARTIN",                                08150000
                        6, 4, "STOP",                                   08155000
                        8, 6, "RESUME",                                 08160000
                        6, 4, "WAIT",                                   08165000
                        8, 6, "DELETE",                                 08170000
                        7, 5, "DEFER",                                  08175000
                        7, 5, "OPENQ",                                  08180000
                        7, 5, "SHUTQ",                                  08185000
                        7, 5, "RESET",                                  08190000
                        0;                                              08195000
   INTEGER ARRAY     KEYWORDSPW (*) = KEYWORDSP,                        08200000
                     KEYWORDSW (0:X2) = Q;                              08205000
   BYTE ARRAY        KEYWORDS (*) = KEYWORDSW;                          08210000
<< BITS CORRESPONDING TO PERMISSABLE KEYWORDS>>                         08215000
   LOGICAL           CONTEXTFLAG := -1;                                 08220000
   INTEGER           KEYNUM;                                            08225000
                                                                        08230000
<< =SPOOL CONTROLLING VARIABLES >>                                      08235000
   INTEGER           DEVICE,                                   <<06744>>08240000
                     LDT'INDEX,                                <<06744>>08245000
                     LPDT'INDEX;                               <<06744>>08250000
   LOGICAL POINTER LDT;                                        <<06744>>08255000
   EQUATE         << DIRECTION >>                                       08260000
                     IN = 0,                                            08265000
                     OUT = 1,                                           08270000
                     EITHER = -1;                                       08275000
   INTEGER           DIRECTION := EITHER;                               08280000
   EQUATE         << SPOOFLING >>                                       08285000
                     SHUT = 0,                                          08290000
                     OPEN = 1,                                          08295000
                     LEAVE = -1;                                        08300000
   INTEGER           SPOOFLING := LEAVE;                                08305000
                  << PROGEN/SPOOLER DIRECTIVE>>                         08310000
   EQUATE            NODIRECTIVE  = %100000;                            08315000
   INTEGER           NEWDIRECTIVE  := NODIRECTIVE;                      08320000
   DEFINE            PROCDIRECTIVE = NEWDIRECTIVE.(8:4) #,              08325000
                     FILEDIRECTIVE = NEWDIRECTIVE.(12:4) #;             08330000
   LOGICAL           STARTFLAG := FALSE;  <<PROCREATE FLAG>>            08335000
                                                                        08340000
<< MISC >>                                                              08345000
   INTEGER           PCBPT,                                    <<06744>>08350000
                     SAVESIR;                                           08355000
   LOGICAL POINTER   PCB = SYSPCBINDEX;                        <<P8391>>08360000
                                                                        08365000
                                                                        08370000
<< >>                                                                   08375000
   LPDT'INDEX := DEVICE*SIZE'OF'LPDT'ENTRY;                    <<06744>>08380000
   CONSSPOOL := FALSE;                                                  08385000
   MYCOMMAND (PARMSTRING, DELIM, 4, NUMPARMS, PARMS);                   08390000
   IF = AND (NUMPARMS >= 2) THEN                                        08395000
      BEGIN    <<VALID NUMBER OF PARMS>>                                08400000
      TOS := 0;                                                         08405000
      TOS := PARMS;                                                     08410000
      TOS := TOS &LSR(8);                                               08415000
      DEVICE := BINARY (*, *);                                          08420000
      IF = THEN                                                         08425000
         BEGIN    <<VALID NUMBER>>                                      08430000
         MOVE KEYWORDSW := KEYWORDSPW, (DICTLEN);                       08435000
         DO BEGIN    <<PROCESS KEYWORDS>>                               08440000
            TOS := 0;                                                   08445000
            TOS := PARMS (PNUM);                                        08450000
            TOS := TOS &LSR(8);                                         08455000
            IF = THEN                                                   08460000
               BEGIN    <<OMITTED PARM>>                                08465000
               ASSEMBLE (DEL, DDEL);                                    08470000
               RETURN;                                                  08475000
               END;                                                     08480000
            << NOT OMITTED >>                                           08485000
            KEYNUM := SEARCH (*, *, KEYWORDS) -1;                       08490000
            IF < THEN RETURN;    <<UNRECOGNIZED KEYWORD>>               08495000
            << RECOGNIZABLE KEYWORD >>                                  08500000
            TOS := CONTEXTFLAG;    <<C IF LEGITIMATE IN CONTEXT>>       08505000
            XREG := KEYNUM;                                             08510000
            ASSEMBLE (TBC 0,X; DEL);                                    08515000
            IF = THEN RETURN;                                           08520000
            << CONTEXTUALLY LEGITIMATE >>                               08525000
                                                                        08530000
            << KEYWORD PROCESSORS                                       08535000
               EACH PROCESSOR LEAVES:                                   08540000
                  S-1 = NEW CONTEXTFLAG,                                08545000
                  S-0 = IMPLIED DIRECTION.  >>                          08550000
            CASE KEYNUM OF                                              08555000
               BEGIN                                                    08560000
<< STARTOUT >>    BEGIN                                                 08565000
                  STARTFLAG := TRUE;                                    08570000
                  PROCDIRECTIVE := RESUMESPOOLING;                      08575000
                  TOS := %600;                                          08580000
                  TOS := OUT;                                           08585000
                  END;                                                  08590000
<< STARTIN >>     BEGIN                                                 08595000
                  STARTFLAG := TRUE;                                    08600000
                  PROCDIRECTIVE := RESUMESPOOLING;                      08605000
                  TOS := 0;                                             08610000
                  TOS := IN;                                            08615000
                  END;                                                  08620000
<< STOP >>        BEGIN                                                 08625000
                  PROCDIRECTIVE := QUITSPOOLING;                        08630000
                  TOS := %3700;                                         08635000
                  TOS := DIRECTION;    <<LEAVE DIRECTION>>              08640000
                  END;                                                  08645000
<< RESUME >>      BEGIN                                                 08650000
                  PROCDIRECTIVE := RESUMESPOOLING;                      08655000
                  TOS := %600;                                          08660000
                  TOS := OUT;                                           08665000
                  END;                                                  08670000
<< WAIT >>        BEGIN                                                 08675000
                  PROCDIRECTIVE := WAITSPOOLING;                        08680000
                  TOS := %3700;                                         08685000
                  TOS := OUT;                                           08690000
                  END;                                                  08695000
<< DELETE >>      BEGIN                                                 08700000
                  FILEDIRECTIVE := DELETEFILE;                          08705000
                  TOS := %24600;                                        08710000
                  TOS := DIRECTION;    <<LEAVE DIRECTION>>              08715000
                  END;                                                  08720000
<< DEFER >>       BEGIN                                                 08725000
                  FILEDIRECTIVE := DEFERFILE;                           08730000
                  TOS := %24600;                                        08735000
                  TOS := OUT;                                           08740000
                  END;                                                  08745000
<< OPENQ >>       BEGIN                                                 08750000
                  SPOOFLING := OPEN;                                    08755000
                  TOS := %137700;                                       08760000
                  TOS := OUT;                                           08765000
                  END;                                                  08770000
<< SHUTQ >>       BEGIN                                                 08775000
                  SPOOFLING := SHUT;                                    08780000
                  TOS := %137700;                                       08785000
                  TOS := OUT;                                           08790000
                  END;                                                  08795000
<< RESET >>       BEGIN                                                 08800000
                  FILEDIRECTIVE := RELINKFILE;                          08805000
                  TOS := %24600;                                        08810000
                  TOS := OUT;                                           08815000
                  END  <<LAST CASE STATEMENT>>                          08820000
               END;    <<CASE>>                                         08825000
            DIRECTION := TOS;                                           08830000
            CONTEXTFLAG := TOS LAND CONTEXTFLAG;                        08835000
            END                                                         08840000
         UNTIL (PNUM := PNUM +1) = NUMPARMS;                            08845000
                                                                        08850000
         IF STARTFLAG THEN                                              08855000
            BEGIN                                                       08860000
            IF (DIRECTION = OUT) AND (SPOOFLING <> SHUT) THEN           08865000
               DIRECTION := 3;                                          08870000
            IF INITIATESPOOLER (DEVICE, DIRECTION) = 0 THEN             08875000
               CONSSPOOL := TRUE;                                       08880000
            END                                                         08885000
         ELSE                                                           08890000
            BEGIN    <<[OPEN/SHUT Q] AND SEND DIRECTIVE>>               08895000
            LDT'INDEX := DEVICE * SIZE'OF'LDT'ENTRY;           <<06744>>08900000
            @LDT := 0;                                         <<06744>>08905000
            EXCHANGEDB (LDT'DST);                              <<06744>>08910000
            SAVESIR := GETSIR (LDT'SIR);                       <<06744>>08915000
            IF  (1 <= DEVICE <= INTEGER(LDT'NUM'ENTRIES))      <<06744>>08920000
               AND  NOT LPDT'VIRTUAL'DEVICE THEN               <<06744>>08925000
               IF NEWDIRECTIVE = NODIRECTIVE THEN                       08930000
                  BEGIN    <<JUST CHANGING OPENQ/SHUTQ>>                08935000
                  IF VALIDSPOOLEE (LDT'DEVICE'TYPE,TRUE)       <<06744>>08940000
                     THEN                                      <<06744>>08945000
                     BEGIN    <<VALID OUTPUT SPOOLEE: CHANGE>>          08950000
                     LDT'SPOOL'QUEUES := SPOOFLING;            <<06744>>08955000
                     CONSSPOOL := TRUE;                                 08960000
                     END;                                               08965000
                  END                                                   08970000
               ELSE                                                     08975000
                  IF LDT'SPOOL'STATE <> LDT'NOT'SPOOLED THEN   <<06744>>08980000
                     << A SPOOLER >>                                    08985000
                     IF (DIRECTION = EITHER)                            08990000
                     OR (DIRECTION+1=INTEGER(LDT'SPOOL'STATE)) <<06744>>08995000
                        THEN                                   <<06744>>09000000
                        BEGIN    <<CORRECT DIRECTION>>                  09005000
                        IF PROCDIRECTIVE = QUITSPOOLING THEN            09010000
                           BEGIN                                        09015000
                           IF SPOOFLING = LEAVE THEN                    09020000
                              SPOOFLING := SHUT;                        09025000
                           END;                                         09030000
                        IF SPOOFLING <> LEAVE THEN                      09035000
                           LDT'SPOOL'QUEUES := SPOOFLING;      <<06744>>09040000
                        << SEND DIRECTIVE >>                            09045000
                        PCBPT := LDT'MAIN'PIN*                 <<06744>>09050000
                              PCBSIZE;                                  09055000
                        EXCHANGEDB(SPCBSTKDST);                <<06744>>09060000
                                                               <<06744>>09065000
                        DBP (DIRECTIV) := NEWDIRECTIVE;                 09070000
                        AWAKE (PCBPT, DADWAIT, 0);             <<06744>>09075000
                        CONSSPOOL := TRUE;                              09080000
                        END;                                            09085000
            IF RESULT AND SPOOFLING=OPEN THEN                           09090000
               BEGIN                                                    09095000
               DISABLE;                                                 09100000
               SYSDEVAVAIL := TRUE;                            <<07438>>09105000
               ENABLE;                                                  09110000
               AWAKE (SYSUCOPPCB, JUNKWAIT, 0);                <<07438>>09115000
               END;                                                     09120000
            RELSIR (LDT'SIR, SAVESIR);                         <<06744>>09125000
            EXCHANGEDB (0);                                             09130000
            END;                                                        09135000
         END;                                                           09140000
      END;                                                              09145000
   END;    <<CONSSPOOL>>                                                09150000
$PAGE  "DISC READ, WRITE"                                      <<07063>>09155000
LOGICAL PROCEDURE DISC (FUNC, LDEV, DISCADR, BUFFER, COUNT);   <<07063>>09160000
   VALUE   FUNC, LDEV, DISCADR, COUNT;                         <<07063>>09165000
   INTEGER FUNC, LDEV, COUNT;                                  <<07063>>09170000
   LOGICAL ARRAY BUFFER;                                       <<07063>>09175000
   DOUBLE  DISCADR;                                            <<07063>>09180000
   OPTION  PRIVILEGED, UNCALLABLE;                             <<07063>>09185000
BEGIN                                                          <<07063>>09190000
INTEGER DISCADR1 = DISCADR,                                    <<07063>>09195000
        DISCADR2 = DISCADR + 1;                                <<07063>>09200000
TOS := ATTACHIO (LDEV, 0, 0, @BUFFER, FUNC, COUNT,             <<07063>>09205000
                 DISCADR1, DISCADR2, 1);                       <<07063>>09210000
DEL;   << Don't need transmission log.                   >>    <<07063>>09215000
DISC := (TOS.(8:8) = 1);                                       <<07063>>09220000
END;  <<DISC>>                                                 <<07063>>09225000
$PAGE "GET'SPOOFLE'DISC'SPACE"                                 <<07063>>09230000
$CONTROL SEGMENT = SPOOLCOMS1                                  <<07063>>09235000
                                                               <<07063>>09240000
LOGICAL PROCEDURE GET'SPOOFLE'DISC'SPACE (XDD'SUBENTRY);       <<07063>>09245000
   VALUE           XDD'SUBENTRY;                               <<07063>>09250000
   LOGICAL POINTER XDD'SUBENTRY;                               <<07063>>09255000
   OPTION PRIVILEGED, UNCALLABLE;                              <<07063>>09260000
                                                               <<07063>>09265000
BEGIN COMMENT --                                               <<07063>>09270000
  GET'SPOOFLE'DISC'SPACE reallocates  spool  file  space  lost <<07063>>09275000
when INITIAL does a Recover Lost Disc Space. The spool file is <<07063>>09280000
assumed to be complete, with an accurate  description  in  its <<07063>>09285000
file label and XDD subentry.                                   <<07063>>09290000
  Using the XDD subentry image in the input parameter, we read <<07063>>09295000
the file label, then allocate space for all the extents in the <<07063>>09300000
extent map.                                                    <<07063>>09305000
  This procedure fails (with a FALSE functional return) if any <<07063>>09310000
of the following are detected:                                 <<07063>>09315000
1.  An ATTACHIO error while reading the file label.            <<07063>>09320000
2.  A file label checksum error (except a checksum of 0 is al- <<07063>>09325000
    lowed.                                                     <<07063>>09330000
3.  Any part of the space in the extent is already in use.     <<07063>>09335000
  Before reporting the failure, we return any  space  we  were <<07063>>09340000
able to allocate before the error.                             <<07063>>09345000
                                                               <<07063>>09350000
Input:   XDD'SUBENTRY, points to an XDD subentry image, usual- <<07063>>09355000
         ly a local copy in the calling procedure.  Must be  a <<07063>>09360000
         stack-DB relative address.  Not changed.              <<07063>>09365000
                                                               <<07063>>09370000
Output:  TRUE if all spoofle disc space was  reallocated  suc- <<07063>>09375000
         cessfully, FALSE otherwise.                           <<07063>>09380000
                                                               <<07063>>09385000
Special considerations:  DB must be at  the  stack  at  entry, <<07063>>09390000
                         same at exit.                         <<07063>>09395000
;                                                              <<07063>>09400000
EQUATE                                                         <<07063>>09405000
   MSG482 = 482,   << Message number in $SET1 of CATALOG.   >> <<W7791>>09410000
   READ   =   0,   << ATTACHIO function code.               >> <<W7791>>09415000
   SET1   =   1;   << Message set number in CATALOG.        >> <<W7791>>09420000
                                                               <<07063>>09425000
INTEGER                                                        <<07063>>09430000
   COMMUNICATION'DST,   << INITIAL passes info to PROGEN.   >> <<07063>>09435000
   I,                                                          <<07063>>09440000
   J,                                                          <<07063>>09445000
   LDEV,                                                       <<W7791>>09450000
   LENGTH;                                                     <<W7791>>09455000
                                                               <<07063>>09460000
LOGICAL                                                        <<07063>>09465000
   EXTENT'SIZE;         << # sectors in spool file extent.  >> <<W7791>>09470000
                                                               <<W7791>>09475000
LOGICAL ARRAY                                                  <<W7791>>09480000
   MSG'PARM(0:11);      << Parameter string for GENMSG.     >> <<W7791>>09485000
BYTE ARRAY                                                     <<W7791>>09490000
   MSG'PARM'B(*) = MSG'PARM;                                   <<W7791>>09495000
                                                               <<W7791>>09500000
DOUBLE                                                         <<W7791>>09505000
   DISC'ADDRESS,        << Sector address for disc I/O.     >> <<W7791>>09510000
   DISC'LENGTH;         << Length of disc I/O.              >> <<07063>>09515000
                                                               <<07063>>09520000
INTEGER ARRAY                                                  <<07063>>09525000
   FLAB(0:127);         << Holds local copy of file label.  >> <<07063>>09530000
DOUBLE ARRAY                                                   <<07063>>09535000
   FLABDBL(*) = FLAB;                                          <<07063>>09540000
                                                               <<07063>>09545000
DOUBLE POINTER                                                 <<07063>>09550000
   EXTENT'MAP;          << Based at file label extent map.  >> <<07063>>09555000
                                                               <<07063>>09560000
GET'SPOOFLE'DISC'SPACE := FALSE;                               <<07063>>09565000
EXTENT'SIZE := SYSSPEXTNTSEC;                                  <<07063>>09570000
                                                               <<07063>>09575000
<< Read the file label here.                                >> <<07063>>09580000
                                                               <<07063>>09585000
LDEV := LUN (XDDS'SPOOFLE'VT'INDEX, 0);                        <<07063>>09590000
TOS := XDDS'MSW'LABEL;                                         <<07063>>09595000
TOS := XDDS'LSW'LABEL;                                         <<07063>>09600000
DISC'ADDRESS := TOS;                                           <<07063>>09605000
IF NOT DISC (READ, LDEV, DISC'ADDRESS, FLAB, WORDSPERSECTOR)   <<07063>>09610000
   THEN RETURN;   << I/O error reading file label.          >> <<07063>>09615000
<< TOS := >> CHECKSUM;                                         <<W7791>>09620000
IF TOS <> FLCHECKSUM AND FLCHECKSUM <> 0 THEN GO REPORT'ERROR; <<W7791>>09625000
                                                               <<W7791>>09630000
<< Now tiptoe through the extents.                          >> <<W7791>>09635000
                                                               <<W7791>>09640000
@EXTENT'MAP := @FLLABEL;                                       <<W7791>>09645000
DISC'LENGTH := DOUBLE (EXTENT'SIZE);   << Except for last.  >> <<W7791>>09650000
I := -1;                                                       <<W7791>>09655000
WHILE EXTENT'MAP(I := I + 1) <> 0D AND I <= FLNUMEXTS DO       <<W7791>>09660000
   BEGIN                                                       <<W7791>>09665000
   TOS := EXTENT'MAP(I);                                       <<W7791>>09670000
   LDEV := LUN (S1.(0:8), 0);                                  <<W7791>>09675000
   S1.(0:8) := 0;                                              <<W7791>>09680000
   DISC'ADDRESS := TOS;                                        <<W7791>>09685000
   IF I = FLNUMEXTS THEN DISC'LENGTH :=                        <<W7791>>09690000
      DOUBLE (XDDS'LAST'EXTENT'SIZE);                          <<W7791>>09695000
   IF GET'SPECIFIC'DISC'SPACE (LDEV, DISC'ADDRESS, DISC'LENGTH)<<W7791>>09700000
          <> 0 THEN                                            <<W7791>>09705000
      BEGIN      << Error trying to get space.              >> <<W7791>>09710000
      DISC'LENGTH := DOUBLE (EXTENT'SIZE);                     <<W7791>>09715000
      J := -1;   << Return everything we took up to now.    >> <<W7791>>09720000
      WHILE (J := J + 1) < I DO                                <<W7791>>09725000
         BEGIN   << This loop returns one extent.           >> <<W7791>>09730000
         TOS := EXTENT'MAP(J);                                 <<W7791>>09735000
         LDEV := LUN (S1.(0:8), 0);                            <<W7791>>09740000
         S1.(0:8) := 0;                                        <<W7791>>09745000
         DISC'ADDRESS := TOS;                                  <<W7791>>09750000
         IF J = FLNUMEXTS THEN DISC'LENGTH :=                  <<W7791>>09755000
            DOUBLE (XDDS'LAST'EXTENT'SIZE);                    <<W7791>>09760000
         RETURN'DISC'SPACE (LDEV, DISC'ADDRESS, DISC'LENGTH);  <<W7791>>09765000
         END;    << This loop returns one extent.           >> <<W7791>>09770000
                                                               <<W7791>>09775000
REPORT'ERROR:                                                  <<W7791>>09780000
                                                               <<W7791>>09785000
      IF XDDS'DFID'IN'OR'OUT = XDDS'DFID'IN THEN               <<W7791>>09790000
         MSG'PARM := "#I"                                      <<W7791>>09795000
      ELSE MSG'PARM := "#O";                                   <<W7791>>09800000
      LENGTH := ASCII (XDDS'DFID'NUMBER, 10, MSG'PARM'B(2));   <<W7791>>09805000
      MSG'PARM'B(LENGTH+2) := 0;   << Terminator.           >> <<W7791>>09810000
      GENMSG (SET1, MSG482, 0, @MSG'PARM'B);                   <<W7791>>09815000
      RETURN;    << Error return.                           >> <<07063>>09820000
      END;       << Error trying to get space.              >> <<07063>>09825000
   END;          << Tiptoe through the extents.             >> <<07063>>09830000
GET'SPOOFLE'DISC'SPACE := TRUE;   << We DID it.             >> <<07063>>09835000
END;   << of GET'SPOOFLE'DISC'SPACE.                        >> <<07063>>09840000
$PAGE "VERIFY'BLOCK"                                           <<07063>>09845000
$CONTROL SEGMENT = SPOOLCOMS1                                  <<07063>>09850000
                                                               <<07063>>09855000
DOUBLE PROCEDURE VERIFY'BLOCK (SPOOFLE'BLOCK);                 <<07063>>09860000
   LOGICAL ARRAY SPOOFLE'BLOCK;                                <<07063>>09865000
   OPTION PRIVILEGED, UNCALLABLE;                              <<07063>>09870000
                                                               <<07063>>09875000
BEGIN COMMENT --                                               <<07063>>09880000
  VERIFY'BLOCK scans a spool file block to  verify  its  block <<07063>>09885000
structure  (variable  length records, with four extra words at <<07063>>09890000
the start of each record and two extra (the record  number  of <<07063>>09895000
the  record  which  starts the block) at the end of the block. <<07063>>09900000
This is in addition to the standard length words at the  start <<07063>>09905000
of  all variable length records, and the -1 word indicating no <<07063>>09910000
more data in the block.                                        <<07063>>09915000
  This procedure is loosely adapted from a  similar  procedure <<07063>>09920000
in SPOOK.                                                      <<07063>>09925000
                                                               <<07063>>09930000
Input:   SPOOFLE'BLOCK, a logical array of the block image.    <<07063>>09935000
                                                               <<07063>>09940000
Result:  The number of records in the block,  -OR-  -1D  if  a <<07063>>09945000
         structural error is detected.                         <<07063>>09950000
;                                                              <<07063>>09955000
EQUATE                                                         <<07063>>09960000
   END'OF'DATA = 509;   << Last valid word in block.        >> <<07063>>09965000
                                                               <<07063>>09970000
INTEGER                                                        <<07063>>09975000
   INDEX := 0,          << Current index into SPOOFLE'BLOCK >> <<07063>>09980000
   RECORD'COUNT := 0,   << Running count of recs in block.  >> <<07063>>09985000
   RECORD'LENGTH;       << Byte length of a given record... >> <<07063>>09990000
                        << ...not including itself.         >> <<07063>>09995000
                                                               <<07063>>10000000
WHILE (RECORD'LENGTH := SPOOFLE'BLOCK(INDEX)) <> -1 AND        <<07063>>10005000
      INDEX <= END'OF'DATA DO                                  <<07063>>10010000
   IF RECORD'LENGTH <= 0 THEN  << Error, -1 already checked >> <<07063>>10015000
      INDEX := END'OF'DATA + 1 << Force error termination.  >> <<07063>>10020000
   ELSE                                                        <<07063>>10025000
      BEGIN   << Advance and count one record.              >> <<07063>>10030000
      INDEX := INDEX + (RECORD'LENGTH + 3) & ASR(1);           <<07063>>10035000
      RECORD'COUNT := RECORD'COUNT + 1;                        <<07063>>10040000
      END;    << Advance and count one record.              >> <<07063>>10045000
IF INDEX > END'OF'DATA THEN                                    <<07063>>10050000
   VERIFY'BLOCK := -1D                                         <<07063>>10055000
ELSE                                                           <<07063>>10060000
   VERIFY'BLOCK := DOUBLE (RECORD'COUNT);                      <<07063>>10065000
END;   << of VERIFY'BLOCK.                                  >> <<07063>>10070000
$PAGE "FIX'OPEN'OUTPUT'SPOOFLE -- comments"                    <<W7675>>10075000
$CONTROL SEGMENT=SPOOLCOMS1                                    <<07063>>10080000
                                                               <<07063>>10085000
LOGICAL PROCEDURE FIX'OPEN'OUTPUT'SPOOFLE (XDD'SUBENTRY);      <<07063>>10090000
   VALUE           XDD'SUBENTRY;                               <<07063>>10095000
   LOGICAL POINTER XDD'SUBENTRY;                               <<07063>>10100000
   OPTION PRIVILEGED, UNCALLABLE;                              <<07063>>10105000
                                                               <<07063>>10110000
BEGIN COMMENT --                                               <<07063>>10115000
  FIX'OPEN'OUTPUT'SPOOFLE works with output files  which  were <<07063>>10120000
OPEN  (being  created) when the system failed.  Our goal is to <<07063>>10125000
recover as much of the file as is possible so  that  the  user <<07063>>10130000
whose  job  ran  5  hours will be able to get 15000 of his/her <<07063>>10135000
20000 lines of output and then curse us for not being able  to <<07063>>10140000
provide the rest.  Sic transit gloria mundi.                   <<07063>>10145000
  If we succeed in our endeavor the result is a  file  and  an <<07063>>10150000
ODD  subentry which look like a vanilla READY file to the rest <<07063>>10155000
of the world, and can therefore be handled by  routines  which <<07063>>10160000
know about READY files. Only the user examining his/her output <<07063>>10165000
will know how s/he was shortchanged.                           <<07063>>10170000
  Once a file is closed, the ODD and the file label provide  a <<07063>>10175000
fairly  (!)  reliable picture of the file's condition.  Not so <<07063>>10180000
while it is OPEN.  Disc postings (the only thing we have to go <<07063>>10185000
on in here) are haphazard. The file label and the extent count <<07063>>10190000
in the ODD are updated each time an extent  is  allocated.  So <<07063>>10195000
far  so  good.  But the ODD record count is only updated every <<07063>>10200000
64 FWRITEs (a magic number).  Furthermore, these  are  logical <<07063>>10205000
FWRITEs.  Because  of  file  system buffering, the actual data <<07063>>10210000
doesn't hit the disc until some time in the future.  This pro- <<07063>>10215000
cedure gets to figure out what is good and what isn't.         <<W7675>>10220000
  We are only called if there is disc space to deal with. Oth- <<W7675>>10225000
er code has determined that our ODD subentry is in  use,  that <<W7675>>10230000
there  is disc space associated with it, and that the subentry <<W7675>>10235000
represents an OPEN spool file.  The rest is up to us. Here are <<W7675>>10240000
the steps we go through:                                       <<W7675>>10245000
1.  The file label address in the ODD was put there when ALLO- <<W7675>>10250000
    CATE acquired the first extent.  We may not have  made  it <<W7675>>10255000
    out  of  the FOPEN which called ALLOCATE, so first we read <<W7675>>10260000
    the file label, verify the checksum (or the absence of one <<W7675>>10265000
    if it's 0), then compare its first extent address with the <<W7675>>10270000
    one in the ODD.  If any of this fails, return  the  extent <<W7675>>10275000
    and report a "can't recover".                              <<W7675>>10280000
2.  With a valid file label in hand, we check next for a  win- <<W7675>>10285000
    dow  condition in FCLOSE.  When a spoolfile is closed, the <<W7675>>10290000
    file label is updated, any unused disc space in the  final <<W7675>>10295000
    extent  is  returned, and the ODD subentry is marked READY <<W7675>>10300000
    (in that order).  The first two events occur one after the <<W7675>>10305000
    other, but there is a large gap between them  and  setting <<W7675>>10310000
    the  ODD  subentry READY.  If the system halts during that <<W7675>>10315000
    time, we will come here on a subsequent WARMSTART to  "re- <<W7675>>10320000
    cover"  an  already  complete spoolfile.  If we attempt to <<W7675>>10325000
    return "unused" space, the Disc Free Space  routines  will <<W7675>>10330000
    crash the system (SF422).                                  <<W7675>>10335000
      To prevent all this, we examine the file  label.  If  it <<W7675>>10340000
    indicates  a  complete  file  (less than 32 extents or the <<W7675>>10345000
    last extent is smaller than  a  configured  spoolfile  ex- <<W7675>>10350000
    tent),  we  confine our activities here to marking the ODD <<W7675>>10355000
    subentry READY and setting a time  stamp  to  prevent  the <<W7675>>10360000
    spooler from appending INCOMPLETE to the trailer.  The re- <<W7675>>10365000
    maining steps described below are then skipped.            <<W7675>>10370000
      Note that there is a short window in FCLOSE between  up- <<W7675>>10375000
    dating  the  file  label and returning unused space in the <<W7675>>10380000
    final extent.  We don't test for that here, thus there  is <<W7675>>10385000
    a  small  chance that this unused space will be lost until <<W7675>>10390000
    the next RECOVER LOST DISC SPACE.                          <<W7675>>10395000
3.  Assuming a truly incomplete file, but with  a  valid  file <<W7675>>10400000
    label,  we may not have been able to write the first block <<W7675>>10405000
    of data.  This requires a little more ingenuity to detect, <<W7675>>10410000
    so we handle it as a special case. First we get a count of <<W7675>>10415000
    extents from the file label. If there is more than one, we <<W7675>>10420000
    obviously have data.  Skip to Step 5 for this.  With  only <<W7675>>10425000
    one  extent,  we  read the first two blocks of data (or at <<W7675>>10430000
    least where they ought to be) and verify  that  the  first <<W7675>>10435000
    record  number  is  0,  the block format of both blocks is <<W7675>>10440000
    correct, and the record number of the first record of  the <<W7675>>10445000
    second  block  is consistent with the number of records in <<W7675>>10450000
    the first block.  If any test fails there is no  data,  so <<W7675>>10455000
    we report a failure as in Step 1.                          <<W7675>>10460000
4.  If we get here, there is some data in  the  file.  Now  we <<W7675>>10465000
    have to find out how much. The ODD record count provides a <<W7675>>10470000
    first approximation.  It is updated every 64 FWRITEs, rain <<07063>>10475000
    or shine.  64 is a magic number, having nothing to do with <<07063>>10480000
    record blocking or anything else.  Because of file  system <<07063>>10485000
    blocking and buffering as well as possible I/O delays, the <<07063>>10490000
    count has a rough tolerance  of  +100/-63.  Short  records <<07063>>10495000
    (such as produced by TDP formatting) in conjunction with a <<07063>>10500000
    count update near the end of a spool file block could  re- <<07063>>10505000
    sult in the large overcount. Large records (say, about 500 <<07063>>10510000
    words) could result in up to 63 records being on the  disc <<07063>>10515000
    which  were  not reflected in the record count.  (The 64th <<07063>>10520000
    such record will update the count).  To  assure  that  the <<07063>>10525000
    record count we use is valid (that is, that the record ex- <<07063>>10530000
    ists on the disc), our target record count is the ODD rec- <<07063>>10535000
    ord count reduced by 150 (also a semi-magic  number),  but <<07063>>10540000
    with a floor of 0.                                         <<07063>>10545000
5.  By this time we have verified that there is some  data  to <<W7675>>10550000
    recover, and we have also made an educated guess as to how <<07063>>10555000
    much.  We want to search the last extent that was  written <<07063>>10560000
    (determined  from  the file label).  It's possible (though <<07063>>10565000
    highly unlikely) that the system failed  AFTER  allocating <<07063>>10570000
    the final extent but BEFORE writing any data to it (assum- <<07063>>10575000
    ing there is more than one extent). To allow for this sit- <<07063>>10580000
    uation we read the final block from the last-but-1  extent <<07063>>10585000
    (which  is  guaranteed  to  be  there), and use the record <<07063>>10590000
    count in it to determine the count as of the start of  the <<07063>>10595000
    final extent.  This serves as a lower limit, with the tar- <<07063>>10600000
    get record as an upper limit.  Using a binary  search,  we <<07063>>10605000
    check  successive  spoofle  block pairs for record numbers <<B7518>>10610000
    consistent with these limits.  This might cause us to read <<B7518>>10615000
    invalid data (on the high side of the  target),  so  block <<B7518>>10620000
    format  and relative record numbers are carefully checked. <<B7518>>10625000
    The theory here is that one block might  pass  the  format <<B7518>>10630000
    test,  but the chance of two such (contiguous) blocks with <<B7518>>10635000
    consistent record numbers is small enough to  be  ignored. <<B7518>>10640000
    When  we  find  the block containing the target record, we <<B7518>>10645000
    then single-step through succeeding blocks until  we  find <<B7518>>10650000
    the last one written.                                      <<B7518>>10655000
6.  If the target record is <= the lower limit,  there  is  no <<W7675>>10660000
    need  for the binary search (the target record is a guess, <<07063>>10665000
    while the lower limit is determined from the file itself). <<07063>>10670000
    In this case we go directly to single-step.                <<07063>>10675000
7.  We then do what FCLOSE didn't get the chance to do:        <<W7675>>10680000
  a)  Return any unused space in the final extent.             <<07063>>10685000
  b)  Update the EOF pointer, the extent count, the final  ex- <<B7518>>10690000
      tent  size,  the  file  limit and the block count in the <<B7518>>10695000
      file label.                                              <<B7518>>10700000
  c)  Update the record count, the extent count and the  final <<07063>>10705000
      extent size in the ODD subentry image.                   <<07438>>10710000
  d)  Set the time stamp in the ODD  to  0.  This  causes  the <<07438>>10715000
      spooler to append INCOMPLETE to the header and trailer.  <<07438>>10720000
  e)  Set the subentry state to READY.                         <<07438>>10725000
                                                               <<07063>>10730000
Input:   XDD'SUBENTRY, points to an XDD subentry image, usual- <<07063>>10735000
         ly a local copy in the calling procedure.  Must be  a <<07063>>10740000
         stack-DB relative address.                            <<07063>>10745000
                                                               <<07063>>10750000
Output:  The function returns FALSE if we find an  error  any- <<07063>>10755000
         where along the line, TRUE otherwise.                 <<07063>>10760000
           The XDD'SUBENTRY image is updated  to  reflect  the <<07063>>10765000
         shortened  file.  So  is  the file label.  Any unused <<07063>>10770000
         space is returned (unless INITIAL already did that as <<07063>>10775000
         part of a Recover Lost Disc Space).                   <<07063>>10780000
                                                               <<07063>>10785000
Special considerations:  DB must be at  the  stack  at  entry, <<07063>>10790000
                         same at exit.                         <<07063>>10795000
;                                                              <<07063>>10800000
$PAGE "FIX'OPEN'OUTPUT'SPOOFLE -- declarations and subroutines"<<W7675>>10805000
EQUATE                                                         <<07063>>10810000
   BLOCK'SIZE        = 512,   << Words per spoofle block.   >> <<07063>>10815000
   MAX'EXTENTS       =  31,   << Max # extents - 1.         >> <<W7675>>10820000
   MSG483            = 483,   << Message                    >> <<W7791>>10825000
   MSG484            = 484,   <<   catalog                  >> <<W7791>>10830000
   MSG485            = 485,   <<     parameters.            >> <<W7791>>10835000
   READ              =   0,   << ATTACHIO function code.    >> <<W7791>>10840000
   SECTORS'PER'BLOCK = BLOCK'SIZE / WORDSPERSECTOR,            <<W7791>>10845000
   SET1              =   1,   << Message catalog parameter. >> <<W7791>>10850000
   WRITE             =   1;   << ATTACHIO function code.    >> <<07063>>10855000
                                                               <<07063>>10860000
INTEGER                                                        <<07063>>10865000
   COMMUNICATION'DST,   << INITIAL passes info to PROGEN.   >> <<07063>>10870000
   FLAB'LDEV,           << LDEV of disc containing FLAB.    >> <<07063>>10875000
   I,                                                          <<07063>>10880000
   LAST'EXTENT,         << Index of last extent in FLAB.    >> <<07063>>10885000
   LDEV,                << LDEV of disc w/ current extent.  >> <<07063>>10890000
   LENGTH,                                                     <<W7791>>10895000
   OFFSET'TO'BLOCK;                                            <<07063>>10900000
                                                               <<07063>>10905000
LOGICAL                                                        <<07063>>10910000
   EXTENT'SIZE,         << # sectors in spool file extent.  >> <<07063>>10915000
   RECOVER'DISC'SPACE,  << INITIAL did Recover Lost Space.  >> <<07063>>10920000
   SINGLE'STEP := FALSE,<< Flag -- advance by single blocks.>> <<07063>>10925000
   STOP;                << Flag -- found last valid block.  >> <<07063>>10930000
                                                               <<07063>>10935000
DOUBLE                                                         <<07063>>10940000
   CURRENT'RECORD,      << Rec # at start of current sector >> <<07063>>10945000
   CURRENT'SECTOR,      << Disc address of current block.   >> <<07063>>10950000
   DISC'ADDRESS,                                               <<07063>>10955000
   DISC'LENGTH,         << Length of disc I/O.              >> <<07063>>10960000
   FIRST'SECTOR,        << Address of 1st sector in extent. >> <<07063>>10965000
   FLAB'SECTOR,         << Address of FLAB on FLAB'LDEV.    >> <<07063>>10970000
   HIGH'SECTOR,         << Top of binary search interval.   >> <<07063>>10975000
   LAST'SECTOR,         << Address+1 of last sctr in extent >> <<B7518>>10980000
   LOW'LIMIT,           << Rec # at start of last extent.   >> <<W7791>>10985000
   LOW'SECTOR,          << Bottom of binary search interval >> <<W7791>>10990000
   RECS'IN'BLOCK,       << # recs in a given spoofle block. >> <<W7791>>10995000
   TARGET'RECORD;       << Object of binary search.         >> <<W7791>>11000000
                                                               <<W7791>>11005000
LOGICAL ARRAY                                                  <<W7791>>11010000
   MSG'PARM(0:11);      << Parameter string for GENMSG.     >> <<W7791>>11015000
BYTE ARRAY                                                     <<W7791>>11020000
   MSG'PARM'B(*) = MSG'PARM;                                   <<W7791>>11025000
                                                               <<07063>>11030000
INTEGER ARRAY                                                  <<07063>>11035000
   FLAB(0:127);         << Holds local copy of file label.  >> <<07063>>11040000
DOUBLE ARRAY                                                   <<07063>>11045000
   FLABDBL(*) = FLAB;                                          <<07063>>11050000
                                                               <<W7791>>11055000
LOGICAL ARRAY                                                  <<W7791>>11060000
   SPOOFLE'BLOCK1(0:2*BLOCK'SIZE-1),   << Holds 2 blocks.   >> <<W7791>>11065000
   SPOOFLE'BLOCK2(*) = SPOOFLE'BLOCK1(BLOCK'SIZE);             <<W7791>>11070000
DOUBLE ARRAY                                                   <<W7791>>11075000
   SPOOFLE'BLKD1(*) = SPOOFLE'BLOCK1,                          <<W7791>>11080000
   SPOOFLE'BLKD2(*) = SPOOFLE'BLOCK2;                          <<W7791>>11085000
                                                               <<W7791>>11090000
DOUBLE POINTER                                                 <<W7791>>11095000
   EXTENT'MAP,          << Based at file label extent map.  >> <<W7791>>11100000
   XDD'DSUBENTRY = XDD'SUBENTRY;                               <<W7791>>11105000
                                                               <<W7791>>11110000
DEFINE                                                         <<W7791>>11115000
   SPOOFLE'BLK1D'START'REC = SPOOFLE'BLKD1(255)#,              <<W7791>>11120000
   SPOOFLE'BLK2D'START'REC = SPOOFLE'BLKD2(255)#;              <<W7791>>11125000
                                                               <<W7791>>11130000
                                                               <<W7791>>11135000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<W7791>>11140000
SUBROUTINE REPORT'FAILURE (MSG'NUMBER);                        <<W7791>>11145000
   VALUE   MSG'NUMBER;                                         <<W7791>>11150000
   INTEGER MSG'NUMBER;                                         <<W7791>>11155000
                                                               <<W7791>>11160000
BEGIN                                                          <<W7791>>11165000
IF XDDS'DFID'IN'OR'OUT = XDDS'DFID'IN THEN                     <<W7791>>11170000
   MSG'PARM := "#I"                                            <<W7791>>11175000
ELSE MSG'PARM := "#O";                                         <<W7791>>11180000
LENGTH := ASCII (XDDS'DFID'NUMBER, 10, MSG'PARM'B(2));         <<W7791>>11185000
MSG'PARM'B(LENGTH + 2) := 0;   << Terminator.               >> <<W7791>>11190000
GENMSG (SET1, MSG'NUMBER, 0, @MSG'PARM'B);                     <<W7791>>11195000
END;   << of REPORT'FAILURE.                                >> <<W7791>>11200000
SUBROUTINE SET'SINGLE'STEP;                                    <<B7518>>11205000
                                                               <<B7518>>11210000
BEGIN COMMENT --                                               <<B7518>>11215000
  SET'SINGLE'STEP initializes CURRENT'RECORD, needed  for  the <<B7518>>11220000
single-step part of our search. It is called only if we get to <<B7518>>11225000
single-step without hitting the block  containing  our  target <<B7518>>11230000
record  during  the  binary search, or if the binary search is <<B7518>>11235000
omitted as being unnecessary.                                  <<B7518>>11240000
;                                                              <<W7790>>11245000
SINGLE'STEP := TRUE;                                           <<B7518>>11250000
IF LOW'SECTOR = FIRST'SECTOR   << then CUR'REC already set. >> <<B7518>>11255000
   OR LOW'LIMIT = 0D           << Same for sngl xtnt file.  >> <<B7518>>11260000
   THEN RETURN;                                                <<B7518>>11265000
IF NOT DISC (READ, LDEV, CURRENT'SECTOR -                      <<B7518>>11270000
       DOUBLE (SECTORS'PER'BLOCK), SPOOFLE'BLOCK1, BLOCK'SIZE) <<B7518>>11275000
   THEN GO REPORT'IO'ERROR;                                    <<W7791>>11280000
CURRENT'RECORD := SPOOFLE'BLK1D'START'REC +                    <<B7518>>11285000
                  VERIFY'BLOCK (SPOOFLE'BLOCK1);               <<B7518>>11290000
END;    << of SET'SINGLE'STEP.                              >> <<B7518>>11295000
$PAGE "FIX'OPEN'OUTPUT'SPOOFLE -- procedure body"              <<W7675>>11300000
FIX'OPEN'OUTPUT'SPOOFLE := FALSE;                              <<B7518>>11305000
COMMUNICATION'DST := SYSCOMMDSTN;                              <<B7518>>11310000
MOVEFROMDSEG (RECOVER'DISC'SPACE, COMMUNICATION'DST, 3, 1);    <<B7518>>11315000
EXTENT'SIZE := SYSSPEXTNTSEC;                                  <<B7518>>11320000
                                                               <<B7518>>11325000
<< Read the file label.                                     >> <<B7518>>11330000
                                                               <<B7518>>11335000
TOS := XDDSD'DISC'LABEL;                                       <<B7518>>11340000
FLAB'LDEV := LUN (S1.(0:8), 0);                                <<B7518>>11345000
S1.(0:8) := 0;                                                 <<B7518>>11350000
FLAB'SECTOR := TOS;                                            <<B7518>>11355000
IF NOT DISC (READ, FLAB'LDEV, FLAB'SECTOR, FLAB,               <<B7518>>11360000
             WORDSPERSECTOR) THEN GO RETURN'1ST'EXTENT;        <<W7675>>11365000
@EXTENT'MAP := @FLLABEL;                                       <<B7518>>11370000
                                                               <<B7518>>11375000
<< Verify the checksum (or lack of it if it's 0). Then com- >> <<B7518>>11380000
<< pare the XDD first extent address with  the  file  label >> <<07063>>11385000
<< first extent address.                                    >> <<07063>>11390000
                                                               <<07063>>11395000
<< TOS := >> CHECKSUM;                                         <<W7791>>11400000
IF TOS <> FLCHECKSUM AND FLCHECKSUM <> 0                       <<07063>>11405000
       OR XDDSD'DISC'LABEL <> EXTENT'MAP THEN                  <<07063>>11410000
   BEGIN   << Bad file label.                               >> <<W7675>>11415000
                                                               <<W7675>>11420000
RETURN'1ST'EXTENT:                                             <<W7675>>11425000
                                                               <<W7675>>11430000
   IF NOT RECOVER'DISC'SPACE THEN                              <<W7675>>11435000
      RETURN'DISC'SPACE (FLAB'LDEV, FLAB'SECTOR,               <<07063>>11440000
                         DOUBLE (EXTENT'SIZE));                <<W7791>>11445000
   REPORT'FAILURE (MSG483);                                    <<W7791>>11450000
   RETURN;                                                     <<W7675>>11455000
   END;                                                        <<W7675>>11460000
IF FLNUMEXTS = MAX'EXTENTS                                     <<W7675>>11465000
   AND FLLASTEXTSIZE = INTEGER (EXTENT'SIZE) THEN              <<W7675>>11470000
   BEGIN   << File label says file not crunched yet.        >> <<W7675>>11475000
                                                               <<07063>>11480000
<< Allow for delays in posting data to disc after  the  re- >> <<07063>>11485000
<< cord count has been updated in the ODD.                  >> <<07063>>11490000
                                                               <<07063>>11495000
   TARGET'RECORD := XDDSD'RECORD'COUNT - 150D;                 <<W7675>>11500000
   IF TARGET'RECORD < 0D THEN TARGET'RECORD := 0D;             <<W7675>>11505000
                                                               <<07063>>11510000
<< Find the final extent allocated.                         >> <<07063>>11515000
                                                               <<07063>>11520000
   I := -1;                                                    <<W7675>>11525000
   WHILE EXTENT'MAP(I := I + 1) <> 0D AND I <= FLNUMEXTS DO;   <<W7675>>11530000
   IF (LAST'EXTENT := I - 1) = 0 THEN                          <<W7675>>11535000
      BEGIN   << Only one extent, see if there's data.      >> <<W7675>>11540000
      DISC'ADDRESS := FLAB'SECTOR + DOUBLE (FLSECTOFF);        <<W7675>>11545000
      IF NOT DISC (READ, FLAB'LDEV, DISC'ADDRESS,              <<W7675>>11550000
         SPOOFLE'BLOCK1, 2 * BLOCK'SIZE) THEN                  <<W7791>>11555000
         GO REPORT'NO'DATA;                                    <<W7791>>11560000
      IF SPOOFLE'BLK1D'START'REC <> 0D THEN GO REPORT'NO'DATA; <<W7791>>11565000
      RECS'IN'BLOCK := VERIFY'BLOCK (SPOOFLE'BLOCK1);          <<W7675>>11570000
      IF RECS'IN'BLOCK = -1D                                   <<W7675>>11575000
         OR VERIFY'BLOCK (SPOOFLE'BLOCK2) = -1D                <<W7675>>11580000
         OR SPOOFLE'BLK2D'START'REC <> RECS'IN'BLOCK THEN      <<W7675>>11585000
         BEGIN                                                 <<W7791>>11590000
                                                               <<W7791>>11595000
REPORT'NO'DATA:                                                <<W7791>>11600000
                                                               <<W7791>>11605000
         REPORT'FAILURE (MSG483);                              <<W7791>>11610000
         GO CLEANUP;                                           <<W7791>>11615000
         END;                                                  <<W7791>>11620000
                                                               <<W7791>>11625000
<< Valid block with data in it if  we're  here.  Initialize >> <<W7791>>11630000
<< all the binary search and single-step variables.         >> <<W7791>>11635000
                                                               <<W7791>>11640000
      LDEV := FLAB'LDEV;                                       <<W7791>>11645000
      FIRST'SECTOR := FLAB'SECTOR;                             <<W7791>>11650000
      LAST'SECTOR := HIGH'SECTOR :=                            <<W7791>>11655000
                     FIRST'SECTOR + DOUBLE (EXTENT'SIZE);      <<W7791>>11660000
      LOW'SECTOR := DISC'ADDRESS;   << Skip user labels.    >> <<W7675>>11665000
      CURRENT'RECORD := LOW'LIMIT := 0D;                       <<W7675>>11670000
      END    << Only one extent, see if there's data.       >> <<W7675>>11675000
   ELSE                                                        <<W7675>>11680000
      BEGIN   << Get record number of start of last extent. >> <<W7675>>11685000
      TOS := EXTENT'MAP(LAST'EXTENT - 1);                      <<W7675>>11690000
      LDEV := LUN (S1.(0:8), 0);                               <<W7675>>11695000
      S1.(0:8) := 0;                                           <<W7675>>11700000
      DISC'ADDRESS := TOS + DOUBLE (EXTENT'SIZE -              <<W7675>>11705000
                      SECTORS'PER'BLOCK);                      <<W7675>>11710000
      IF NOT DISC (READ, LDEV, DISC'ADDRESS, SPOOFLE'BLOCK1,   <<W7675>>11715000
         BLOCK'SIZE) THEN GO REPORT'IO'ERROR;                  <<W7791>>11720000
      IF (RECS'IN'BLOCK := VERIFY'BLOCK (SPOOFLE'BLOCK1)) = -1D<<W7675>>11725000
         THEN                                                  <<W7791>>11730000
         BEGIN   << "Format error in spoolfile #Oxxxxx"     >> <<W7791>>11735000
         REPORT'FAILURE (MSG484);                              <<W7791>>11740000
         GO CLEANUP;                                           <<W7791>>11745000
         END;    << "Format error in spoolfile #Oxxxxx"     >> <<W7791>>11750000
      LOW'LIMIT := CURRENT'RECORD :=                           <<W7791>>11755000
                   SPOOFLE'BLK1D'START'REC + RECS'IN'BLOCK;    <<W7791>>11760000
      TOS := EXTENT'MAP(LAST'EXTENT);                          <<W7791>>11765000
      LDEV := LUN (S1.(0:8), 0);                               <<W7675>>11770000
      S1.(0:8) := 0;                                           <<W7675>>11775000
      FIRST'SECTOR := LOW'SECTOR := TOS;                       <<W7675>>11780000
      LAST'SECTOR := HIGH'SECTOR :=                            <<W7675>>11785000
                     LOW'SECTOR + DOUBLE (EXTENT'SIZE);        <<W7675>>11790000
      END;    << Get record number of start of last extent. >> <<W7675>>11795000
                                                               <<07063>>11800000
<< Search last extent, unless it's not necessary.           >> <<07063>>11805000
                                                               <<07063>>11810000
   IF TARGET'RECORD <= LOW'LIMIT THEN                          <<W7675>>11815000
      BEGIN   << No need to search, interval is already 0.  >> <<W7675>>11820000
      CURRENT'SECTOR := LOW'SECTOR;                            <<W7675>>11825000
      SINGLE'STEP := TRUE;                                     <<W7675>>11830000
      END;                                                     <<W7675>>11835000
                                                               <<07063>>11840000
   WHILE NOT SINGLE'STEP DO                                    <<W7675>>11845000
      BEGIN   << Binary search for target record.           >> <<W7675>>11850000
      IF LOW'SECTOR + DOUBLE (SECTORS'PER'BLOCK) >=            <<W7675>>11855000
         HIGH'SECTOR THEN SET'SINGLE'STEP                      <<W7675>>11860000
      ELSE                                                     <<W7675>>11865000
         BEGIN   << This section does one search iteration. >> <<W7675>>11870000
                                                               <<07063>>11875000
<< The following statements ensure that we always read  be- >> <<07063>>11880000
<< ginning at a block boundary.                             >> <<07063>>11885000
                                                               <<07063>>11890000
         CURRENT'SECTOR := (LOW'SECTOR + HIGH'SECTOR) / 2D;    <<W7675>>11895000
         OFFSET'TO'BLOCK := (CURRENT'SECTOR - LOW'SECTOR) MODD <<W7675>>11900000
            SECTORS'PER'BLOCK;                                 <<W7675>>11905000
         IF OFFSET'TO'BLOCK <> 0 THEN CURRENT'SECTOR :=        <<W7675>>11910000
            CURRENT'SECTOR - DOUBLE (OFFSET'TO'BLOCK);         <<W7791>>11915000
         IF CURRENT'SECTOR + DOUBLE (SECTORS'PER'BLOCK) >=     <<W7791>>11920000
            LAST'SECTOR THEN SET'SINGLE'STEP                   <<W7791>>11925000
         ELSE                                                  <<W7791>>11930000
            BEGIN   << At least 2 blocks to end of extent.  >> <<W7791>>11935000
            IF NOT DISC (READ, LDEV, CURRENT'SECTOR,           <<W7791>>11940000
               SPOOFLE'BLOCK1, 2 * BLOCK'SIZE) THEN            <<W7791>>11945000
               GO REPORT'IO'ERROR;                             <<W7791>>11950000
            RECS'IN'BLOCK := VERIFY'BLOCK (SPOOFLE'BLOCK1);    <<W7675>>11955000
            IF RECS'IN'BLOCK = -1D  << Invalid block format >> <<W7675>>11960000
               OR VERIFY'BLOCK (SPOOFLE'BLOCK2) = -1D          <<W7675>>11965000
               OR SPOOFLE'BLK2D'START'REC <>                   <<W7675>>11970000
                  SPOOFLE'BLK1D'START'REC + RECS'IN'BLOCK      <<W7675>>11975000
               OR SPOOFLE'BLK1D'START'REC > TARGET'RECORD      <<W7675>>11980000
               OR SPOOFLE'BLK1D'START'REC < LOW'LIMIT THEN     <<W7675>>11985000
               HIGH'SECTOR := CURRENT'SECTOR  << Move lower >> <<W7675>>11990000
            ELSE IF SPOOFLE'BLK1D'START'REC + RECS'IN'BLOCK <= <<W7675>>11995000
                 TARGET'RECORD THEN                            <<W7675>>12000000
              LOW'SECTOR := CURRENT'SECTOR   << Move higher >> <<W7675>>12005000
            ELSE                                               <<W7675>>12010000
               BEGIN   << Hit block with target.            >> <<W7675>>12015000
               SINGLE'STEP := TRUE;                            <<W7675>>12020000
               CURRENT'SECTOR := CURRENT'SECTOR +              <<W7675>>12025000
                                 DOUBLE (SECTORS'PER'BLOCK);   <<W7675>>12030000
               CURRENT'RECORD := SPOOFLE'BLK2D'START'REC;      <<W7675>>12035000
               END;    << Hit block with target.            >> <<W7675>>12040000
            END;    << At least 2 blocks to end of extent.  >> <<W7675>>12045000
         END;   << This section does one search iteration.  >> <<W7675>>12050000
      END;   << Binary search for target record.            >> <<W7675>>12055000
                                                               <<07063>>12060000
<< From here on it's single-step.  Read each block,  verify >> <<07063>>12065000
<< its  structure,  and check that it logically follows the >> <<07063>>12070000
<< previous block.  Whenever any  test  fails,  that's  our >> <<07063>>12075000
<< stopping point.                                          >> <<07063>>12080000
                                                               <<07063>>12085000
   STOP := FALSE;   << Our normal quit time flag.           >> <<W7675>>12090000
   WHILE CURRENT'SECTOR < LAST'SECTOR AND NOT STOP DO          <<W7675>>12095000
      BEGIN   << Check the current block.                   >> <<W7675>>12100000
      IF NOT DISC (READ, LDEV, CURRENT'SECTOR, SPOOFLE'BLOCK1, <<W7675>>12105000
                   BLOCK'SIZE) THEN GO REPORT'IO'ERROR;        <<W7791>>12110000
      RECS'IN'BLOCK := VERIFY'BLOCK (SPOOFLE'BLOCK1);          <<W7675>>12115000
      IF RECS'IN'BLOCK = -1D                                   <<W7675>>12120000
         OR SPOOFLE'BLK1D'START'REC <> CURRENT'RECORD THEN     <<W7675>>12125000
         STOP := TRUE                                          <<W7675>>12130000
      ELSE                                                     <<W7675>>12135000
         BEGIN   << Block checks, advance to next one.      >> <<W7675>>12140000
         CURRENT'RECORD := CURRENT'RECORD + RECS'IN'BLOCK;     <<W7675>>12145000
         CURRENT'SECTOR := CURRENT'SECTOR +                    <<W7675>>12150000
                           DOUBLE (SECTORS'PER'BLOCK);         <<W7675>>12155000
         END;    << Block checks, advance to next one.      >> <<W7675>>12160000
      END;   << Check the current block.                    >> <<W7675>>12165000
   IF CURRENT'SECTOR = FIRST'SECTOR THEN                       <<W7675>>12170000
      BEGIN   << Nothing in last extent, delete it.         >> <<W7675>>12175000
      FLNUMEXTS := LAST'EXTENT - 1;                            <<W7675>>12180000
      FLLASTEXTSIZE := EXTENT'SIZE;                            <<W7675>>12185000
      IF NOT RECOVER'DISC'SPACE THEN                           <<W7675>>12190000
         RETURN'DISC'SPACE (LDEV, FIRST'SECTOR,                <<W7675>>12195000
                            DOUBLE (EXTENT'SIZE));             <<W7675>>12200000
      EXTENT'MAP(LAST'EXTENT) := 0D;                           <<W7675>>12205000
      END     << Nothing in last extent, delete it.         >> <<W7675>>12210000
   ELSE                                                        <<W7675>>12215000
      BEGIN   << Return unused space in final extent.       >> <<W7675>>12220000
      FLNUMEXTS := LAST'EXTENT;                                <<W7675>>12225000
      FLLASTEXTSIZE := LOGICAL (CURRENT'SECTOR - FIRST'SECTOR);<<W7675>>12230000
      IF LAST'EXTENT = 0 THEN FLEXTSIZE := FLLASTEXTSIZE;      <<W7675>>12235000
      IF NOT RECOVER'DISC'SPACE THEN                           <<W7675>>12240000
         BEGIN   << Return space only if not already retnd. >> <<W7675>>12245000
         RETURN'DISC'SPACE (LDEV, CURRENT'SECTOR,              <<W7675>>12250000
                            LAST'SECTOR - CURRENT'SECTOR);     <<W7675>>12255000
         END;                                                  <<W7675>>12260000
      END;    << Return unused space in final extent.       >> <<W7675>>12265000
   FLFLIM := FLEOF := CURRENT'RECORD;                          <<W7675>>12270000
   FLSTART := 0D;                                              <<W7675>>12275000
   FLEND := (DOUBLE (FLNUMEXTS) * DOUBLE (FLEXTSIZE) +         <<W7675>>12280000
             DOUBLE (FLLASTEXTSIZE - FLSECTOFF)) /             <<W7675>>12285000
             DOUBLE (SECTORS'PER'BLOCK) - 1D;                  <<W7675>>12290000
   XDDSD'READY'TIME := 0D;  << Spooler marks hdr INCOMPLETE >> <<W7675>>12295000
   << TOS := >> CHECKSUM;  << Recompute file label checksum >> <<W7791>>12300000
   FLCHECKSUM := TOS;                                          <<W7675>>12305000
                                                               <<07063>>12310000
<< We're all done, except for posting the file label.       >> <<07063>>12315000
                                                               <<07063>>12320000
   IF NOT DISC (WRITE, FLAB'LDEV, FLAB'SECTOR, FLAB,           <<W7675>>12325000
               WORDSPERSECTOR) THEN GO CLEANUP;                <<W7675>>12330000
   END     << File label says file not crunched yet.        >> <<W7675>>12335000
ELSE   << File actually complete, set time stamp in XDD.    >> <<W7675>>12340000
   XDDSD'READY'TIME := DOUBLETIME;                             <<W7675>>12345000
XDDS'NUMBER'EXTENTS := FLNUMEXTS + 1;   << Clean up XDD.    >> <<W7675>>12350000
XDDS'LAST'EXTENT'SIZE := FLLASTEXTSIZE;                        <<W7675>>12355000
XDDSD'RECORD'COUNT := FLEOF;                                   <<W7675>>12360000
XDDS'SPOOL'STATE := XDDS'READY;                                <<W7675>>12365000
FIX'OPEN'OUTPUT'SPOOFLE := TRUE;                               <<W7675>>12370000
RETURN;   << *-*-* Normal exit here. *-*-*                  >> <<W7675>>12375000
                                                               <<07063>>12380000
REPORT'IO'ERROR:                                               <<W7791>>12385000
                                                               <<W7791>>12390000
REPORT'FAILURE (MSG485);                                       <<W7791>>12395000
                                                               <<W7791>>12400000
<< Fall in or branch to CLEANUP on an error which makes  it >> <<W7791>>12405000
<< impossible to recover the file. Return all allocated ex- >> <<W7791>>12410000
<< tents (unless they've already been returned  by  Recover >> <<W7791>>12415000
<< Lost Disc Space) and leave.                              >> <<W7791>>12420000
                                                               <<07063>>12425000
CLEANUP:                                                       <<07063>>12430000
                                                               <<07063>>12435000
IF NOT RECOVER'DISC'SPACE THEN                                 <<07063>>12440000
   BEGIN   << Return all allocated extents.                 >> <<07063>>12445000
   DISC'LENGTH := DOUBLE (EXTENT'SIZE);                        <<07063>>12450000
   I := -1;                                                    <<07063>>12455000
   WHILE EXTENT'MAP(I := I + 1) <> 0D AND I <= LAST'EXTENT DO  <<07063>>12460000
      BEGIN   << This loop returns one extent.              >> <<07063>>12465000
      IF I = FLNUMEXTS THEN                                    <<07063>>12470000
         DISC'LENGTH := DOUBLE (FLLASTEXTSIZE);                <<07063>>12475000
      TOS := EXTENT'MAP(I);                                    <<07063>>12480000
      LDEV := LUN (S1.(0:8), 0);                               <<07063>>12485000
      S1.(0:8) := 0;                                           <<07063>>12490000
      DISC'ADDRESS := TOS;                                     <<07063>>12495000
      RETURN'DISC'SPACE (LDEV, DISC'ADDRESS, DISC'LENGTH);     <<07063>>12500000
      EXTENT'MAP(I) := 0D;                                     <<07063>>12505000
      END;    << This loop returns one extent.              >> <<07063>>12510000
   END;    << Return all allocated extents.                 >> <<07063>>12515000
END;   << of FIX'OPEN'OUTPUT'SPOOFLE.                       >> <<07063>>12520000
$PAGE "RECOVER'XDD"                                            <<07063>>12525000
$CONTROL SEGMENT=SPOOLCOMS1                                    <<07063>>12530000
                                                               <<07063>>12535000
PROCEDURE RECOVER'XDD;                                         <<07063>>12540000
   OPTION PRIVILEGED, UNCALLABLE;                              <<07063>>12545000
                                                               <<07063>>12550000
BEGIN COMMENT --                                               <<07063>>12555000
  RECOVER'XDD is used during WARMSTARTs to recover all  possi- <<07063>>12560000
ble spool files, both input and output.  The subentry areas of <<07063>>12565000
both the IDD and ODD are scanned.  Each subentry which was  in <<07063>>12570000
use  is  checked  to see if it represents a spool file.  Those <<07063>>12575000
which do not are removed.  Those that do  get  more  checking. <<07063>>12580000
  Input spool files (IDD) which are OPEN or READY are complete <<07063>>12585000
files.  READY files are requeued and will run  sometime  after <<07063>>12590000
the system is fully up.  OPEN files were executing at the time <<07063>>12595000
of the crash.  If their creator specified the  RESTART  option <<07063>>12600000
in  his/her job record, these files will be set READY and will <<07063>>12605000
also be queued.  Other OPEN files will be deleted.             <<07063>>12610000
  Input files which were ACTIVE are the  most  problem.  These <<07063>>12615000
files  were  being  created  when  the system crashed, and are <<07063>>12620000
therefore incomplete. They cannot be executed, and their space <<07063>>12625000
must be returned extent by extent from the file  label  extent <<07063>>12630000
map.  The IDD subentry is then deleted.                        <<07063>>12635000
  Similarly, output spool files which  are  READY,  ACTIVE  or <<07063>>12640000
LOCKED are complete spool files.  They are easy to recover. An <<07063>>12645000
OPEN output spool file is the rough one here, since it was be- <<07063>>12650000
ing created when the system crashed.  We make a  very  careful <<07063>>12655000
search  to locate the last valid spool file block of the file, <<07063>>12660000
then fix up both the disc label and the ODD to match.  If  the <<07063>>12665000
file has no information in it, it is deleted.                  <<07063>>12670000
  If INITIAL did a Recover Lost Disc Space, we have to contend <<07063>>12675000
with an additional level of complexity.  Normally there is  no <<07063>>12680000
recovery during a WARMSTART, but if suspect tracks are deleted <<07063>>12685000
or reassigned, any files on them have to be purged, so the Re- <<07063>>12690000
cover function is automatically invoked.  What happens is that <<07063>>12695000
all file space is set Available in the  free  space  bit  map. <<07063>>12700000
Then  INITIAL traverses the system file directory, reading all <<07063>>12705000
file labels and reallocating all the  extents  called  for  in <<07063>>12710000
those  labels.  Since  spool  files are not in the system file <<07063>>12715000
directory, their space has been marked Available when  we  get <<07063>>12720000
here.  That reverses our present job, since files which cannot <<07063>>12725000
or should not be recovered will have already been deleted (ex- <<07063>>12730000
cept for their XDD subentry, which we'll take care of).  Those <<07063>>12735000
that are recoverable will have to be recovered by reading  the <<07063>>12740000
file  label  and reallocating all the extents, just as INITIAL <<07063>>12745000
did for system files.                                          <<07063>>12750000
                                                               <<07063>>12755000
Special considerations:  DB must be at  the  stack  at  entry, <<07063>>12760000
                         same at exit.                         <<07063>>12765000
;                                                              <<07063>>12770000
EQUATE                                                         <<07063>>12775000
   DELETE =   4,   << File disposition parameter.           >> <<07063>>12780000
   MSG486 = 486,   << Message catalog message number.       >> <<W7791>>12785000
   READ   =   0,   << ATTACHIO function code.               >> <<07063>>12790000
   SET1   =   1,   << Message catalog set number.           >> <<07063>>12795000
   WRITE  =   1;   << ATTACHIO function code.               >> <<07063>>12800000
                                                               <<07063>>12805000
INTEGER                                                        <<07063>>12810000
   COMMUNICATION'DST,   << INITIAL passes info to PROGEN.   >> <<07063>>12815000
   FNUM,                << Returned by FSOPEN.              >> <<07063>>12820000
   I,                                                          <<07063>>12825000
   LAST'POSSIBLE'SUBENTRY,                                     <<07438>>12830000
   LDEV,                                                       <<07063>>12835000
   LDT'INDEX := 0,      << Required by LDT $INCLUDE file.   >> <<07063>>12840000
   LENGTH;                                                     <<07063>>12845000
                                                               <<07063>>12850000
LOGICAL                                                        <<07063>>12855000
   CAN'T'RECOVER,       << Flag -- can't recover spoolfile. >> <<07063>>12860000
   EXTENT'SIZE,         << # sectors in spool file extent.  >> <<07063>>12865000
   HEAD'INDEX,          << Moving XDD head index.           >> <<07063>>12870000
   HEAD'INDEX'LIMIT,    << End of XDD head entry area.      >> <<07063>>12875000
   KILL'IT,             << Flag -- delete XDD entry.        >> <<07063>>12880000
   RECOVER'DISC'SPACE,  << INITIAL did Recover Lost Space.  >> <<07063>>12885000
   UPDATE'XDD;          << Flag -- local XDD subentry dirty >> <<07063>>12890000
                                                               <<07063>>12895000
DOUBLE                                                         <<07063>>12900000
   DISC'ADDRESS,        << Sector address for disc I/O.     >> <<07063>>12905000
   DISC'LENGTH,         << Length of disc I/O.              >> <<07063>>12910000
   TOTAL'SPOOL'SECTORS; << Running count, total goes in...  >> <<07063>>12915000
                        << ...SYSGLOB when we're through.   >> <<07063>>12920000
INTEGER ARRAY                                                  <<07063>>12925000
   FLAB(0:127);         << Holds local copy of file label.  >> <<07063>>12930000
DOUBLE ARRAY                                                   <<07063>>12935000
   FLABDBL(*) = FLAB;                                          <<07063>>12940000
                                                               <<07063>>12945000
LOGICAL ARRAY                                                  <<07063>>12950000
   LDT(0:SIZE'OF'LDT'ENTRY-1);                                 <<07063>>12955000
                                                               <<07063>>12960000
LOGICAL ARRAY                                                  <<07063>>12965000
   XDD(0:SIZE'OF'XDD0-1),                                      <<07063>>12970000
   XDD'HEAD(0:SIZE'OF'XDD'HEAD-1),                             <<07063>>12975000
   XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY-1);                     <<07063>>12980000
DOUBLE ARRAY                                                   <<07063>>12985000
   XDD'DSUBENTRY(*) = XDD'SUBENTRY;                            <<07063>>12990000
INTEGER POINTER                                                <<07063>>12995000
   XDD'ADDRESS;         << XDD offset to current subentry.  >> <<07063>>13000000
                                                               <<07063>>13005000
LOGICAL ARRAY                                                  <<07063>>13010000
   MSG'PARM(0:11);      << Parameter string for GENMSG.     >> <<07063>>13015000
BYTE ARRAY                                                     <<07063>>13020000
   MSG'PARM'B(*) = MSG'PARM;                                   <<07063>>13025000
                                                               <<07063>>13030000
DOUBLE POINTER                                                 <<07063>>13035000
   EXTENT'MAP;          << Based at file label extent map.  >> <<07063>>13040000
                                                               <<07438>>13045000
                                                               <<07438>>13050000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07438>>13055000
                                                               <<07438>>13060000
                                                               <<07438>>13065000
SUBROUTINE DEF'MOVETODSEG;                                     <<07438>>13070000
                                                               <<07438>>13075000
                                                               <<07438>>13080000
SUBROUTINE GET'XDD'SIZE (XDD'DST);                             <<07438>>13085000
   VALUE   XDD'DST;                                            <<07438>>13090000
   INTEGER XDD'DST;                                            <<07438>>13095000
                                                               <<07438>>13100000
BEGIN                                                          <<07438>>13105000
MOVEFROMDSEG (XDD, XDD'DST, 0, SIZE'OF'XDD0);                  <<07438>>13110000
LAST'POSSIBLE'SUBENTRY := XDD0'CURRENT'SECTORS *               <<07438>>13115000
     WORDSPERSECTOR - XDD0'SUBENTRY'LENGTH;                    <<07438>>13120000
END;                                                           <<07438>>13125000
                                                               <<07438>>13130000
                                                               <<07438>>13135000
SUBROUTINE RAISE'OUTFENCE;                                     <<07438>>13140000
                                                               <<07438>>13145000
BEGIN                                                          <<07438>>13150000
MOVEFROMDSEG (XDD, ODD'DST, 0, SIZE'OF'XDD0);                  <<07438>>13155000
XDD0'SYSTEM'OUTFENCE := 14;                                    <<07438>>13160000
HEAD'INDEX := XDD'CLASS'INDEX;   << but we won't use it.    >> <<07438>>13165000
HEAD'INDEX'LIMIT := XDD0'SUBENTRY'AREA / XDD0'HEAD'LENGTH;     <<07438>>13170000
WHILE (HEAD'INDEX := HEAD'INDEX + 1) < HEAD'INDEX'LIMIT DO     <<07438>>13175000
   BEGIN   << Reset all device-specific outfences.          >> <<07438>>13180000
   MOVEFROMDSEG (XDD'HEAD, ODD'DST, HEAD'INDEX *               <<07438>>13185000
                 XDD0'HEAD'LENGTH, XDD0'HEAD'LENGTH);          <<07438>>13190000
   XDDH'DEV'OUTFENCE := 0;                                     <<07438>>13195000
   MOVETODSEG (ODD'DST, HEAD'INDEX*XDD0'HEAD'LENGTH, XDD'HEAD, <<07438>>13200000
               XDD0'HEAD'LENGTH);                              <<07438>>13205000
   END;    << Reset all device-specific outfences.          >> <<07438>>13210000
MOVETODSEG (ODD'DST, 0, XDD, SIZE'OF'XDD0);                    <<07438>>13215000
WRITEDSEG (ODD'DST);                                           <<07438>>13220000
END;    << of RAISE'OUTFENCE.                               >> <<07438>>13225000
                                                               <<07438>>13230000
                                                               <<07438>>13235000
SUBROUTINE SET'UP'LDT (XDD'DST);                               <<07438>>13240000
   VALUE   XDD'DST;                                            <<07438>>13245000
   INTEGER XDD'DST;                                            <<07438>>13250000
                                                               <<07438>>13255000
BEGIN COMMENT --                                               <<07438>>13260000
  Sets the XDD head index for LDEV n into the proper space  in <<07438>>13265000
the LDT entry for LDEV n.  Called for both IDD and ODD.        <<07438>>13270000
;                                                              <<07438>>13275000
HEAD'INDEX := XDD'CLASS'INDEX;   << but we'll skip this one >> <<07438>>13280000
HEAD'INDEX'LIMIT := XDD0'SUBENTRY'AREA / XDD0'HEAD'LENGTH;     <<07438>>13285000
WHILE (HEAD'INDEX := HEAD'INDEX + 1) < HEAD'INDEX'LIMIT DO     <<07438>>13290000
   BEGIN   << This loop handles one LDEV.                   >> <<07438>>13295000
   MOVEFROMDSEG (XDD'HEAD, XDD'DST,                            <<07438>>13300000
       HEAD'INDEX*XDD0'HEAD'LENGTH, XDD0'HEAD'LENGTH);         <<07438>>13305000
   MOVEFROMDSEG (LDT, LDT'DST, XDDH'LDEV*SIZE'OF'LDT'ENTRY,    <<07438>>13310000
       SIZE'OF'LDT'ENTRY);                                     <<07438>>13315000
   LDT'XDD'HEAD'INDEX := HEAD'INDEX;                           <<07438>>13320000
   MOVETODSEG (LDT'DST, XDDH'LDEV*SIZE'OF'LDT'ENTRY, LDT,      <<07438>>13325000
       SIZE'OF'LDT'ENTRY);                                     <<07438>>13330000
   END;    << This loop handles one LDEV.                   >> <<07438>>13335000
END;       << of SET'UP'LDT.                                >> <<07438>>13340000
                                                               <<07438>>13345000
                                                               <<07438>>13350000
COMMUNICATION'DST := SYSCOMMDSTN;                              <<07063>>13355000
MOVEFROMDSEG (RECOVER'DISC'SPACE, COMMUNICATION'DST, 3, 1);    <<07063>>13360000
EXTENT'SIZE := SYSSPEXTNTSEC;                                  <<07063>>13365000
TOTAL'SPOOL'SECTORS := 0D;                                     <<07063>>13370000
$PAGE                                                          <<07063>>13375000
<<**********************************************************>> <<07063>>13380000
<<                                                          >> <<07063>>13385000
<<                   Recover the IDD here.                  >> <<07063>>13390000
<<                                                          >> <<07063>>13395000
<<**********************************************************>> <<07063>>13400000
                                                               <<07063>>13405000
GET'XDD'SIZE (IDD'DST);                                        <<07438>>13410000
@XDD'ADDRESS := XDD0'SUBENTRY'AREA;                            <<07438>>13415000
WHILE @XDD'ADDRESS <= LAST'POSSIBLE'SUBENTRY DO                <<07438>>13420000
   BEGIN   << Check all IDD subentries.                     >> <<07438>>13425000
                                                               <<07438>>13430000
<< As XDD subentries are scanned they may  be  removed.  If >> <<07438>>13435000
<< this results in a large block of available subentries at >> <<07438>>13440000
<< the end of the XDD, SREMOVEXDD  will  collapse  the  XDD >> <<07438>>13445000
<< data segment.  If we use our original XDD length without >> <<07438>>13450000
<< allowing for this,  machines  equipped  with  Privileged >> <<07438>>13455000
<< Mode Bounds Checking (PMBC) will experience an SF10.  To >> <<07438>>13460000
<< avoid this, the segment length is recalculated  whenever >> <<07438>>13465000
<< a subentry is purged.                                    >> <<07438>>13470000
                                                               <<07438>>13475000
   KILL'IT := UPDATE'XDD := FALSE;                             <<07063>>13480000
   MOVEFROMDSEG (XDD'SUBENTRY, IDD'DST, @XDD'ADDRESS,          <<07063>>13485000
                 XDD0'SUBENTRY'LENGTH);                        <<07063>>13490000
   IF XDD'SUBENTRY <> XDDS'UNUSED'SUBENTRY THEN                <<07063>>13495000
      BEGIN   << Entry is being used.                       >> <<07063>>13500000
      IF XDDSD'DISC'LABEL = 0D THEN                            <<07063>>13505000
         KILL'IT := TRUE   << Not a spool file.             >> <<07063>>13510000
      ELSE                                                     <<07063>>13515000
         BEGIN   << A spool file, what do we do with it?    >> <<07063>>13520000
         IF XDDS'SPOOL'STATE = XDDS'ACTIVE THEN                <<07063>>13525000
            BEGIN   << File is incomplete, can't be saved.  >> <<07063>>13530000
            KILL'IT := TRUE;                                   <<07063>>13535000
            IF NOT RECOVER'DISC'SPACE THEN                     <<07063>>13540000
               BEGIN   << Return all space, INITIAL didn't. >> <<07063>>13545000
               IF XDDSD'DISC'LABEL <> 0D THEN                  <<07063>>13550000
                  BEGIN   << There is some space to return. >> <<07063>>13555000
                  LDEV := LUN (XDDS'SPOOFLE'VT'INDEX, 0);      <<07063>>13560000
                  TOS := XDDS'MSW'LABEL;                       <<07063>>13565000
                  TOS := XDDS'LSW'LABEL;                       <<07063>>13570000
                  DISC'ADDRESS := TOS;                         <<07063>>13575000
                  DISC'LENGTH := DOUBLE (EXTENT'SIZE);         <<07063>>13580000
                  IF DISC (READ, LDEV, DISC'ADDRESS, FLAB,     <<07063>>13585000
                           WORDSPERSECTOR) THEN                <<07063>>13590000
                     BEGIN   << Verify checksum, FL addr.   >> <<07063>>13595000
                     @EXTENT'MAP := @FLLABEL;                  <<07063>>13600000
                     << TOS := >> CHECKSUM;                    <<W7791>>13605000
                     IF TOS = FLCHECKSUM OR FLCHECKSUM = 0 THEN<<07063>>13610000
                        IF XDDSD'DISC'LABEL = EXTENT'MAP THEN  <<07063>>13615000
                        BEGIN   << Scan xtnts, return space >> <<07063>>13620000
                        I := -1;                               <<07063>>13625000
                        WHILE EXTENT'MAP(I := I + 1) <> 0D AND <<07063>>13630000
                              I <= FLNUMEXTS DO                <<07063>>13635000
                           BEGIN   << Return one extent.    >> <<07063>>13640000
                           IF I = FLNUMEXTS THEN DISC'LENGTH   <<07063>>13645000
                              := DOUBLE (FLLASTEXTSIZE);       <<07063>>13650000
                           TOS := EXTENT'MAP(I);               <<07063>>13655000
                           LDEV := LUN (S1.(0:8), 0);          <<07063>>13660000
                           S1.(0:8) := 0;                      <<07063>>13665000
                           DISC'ADDRESS := TOS;                <<07063>>13670000
                           RETURN'DISC'SPACE (LDEV,            <<07063>>13675000
                              DISC'ADDRESS, DISC'LENGTH);      <<07063>>13680000
                           END;    << Return one extent.    >> <<07063>>13685000
                        END     << Scan xtnts, return space >> <<07063>>13690000
                     ELSE   << FL bad, retn 1st xtnt via XDD>> <<07063>>13695000
                        RETURN'DISC'SPACE (LDEV, DISC'ADDRESS, <<07063>>13700000
                                           DISC'LENGTH);       <<07063>>13705000
                     END;    << Verify checksum, FL addr.   >> <<07063>>13710000
                  END;    << There is some space to return. >> <<07063>>13715000
               END;    << Return all space, INITIAL didn't. >> <<07063>>13720000
            END     << File is incomplete, can't be saved.  >> <<07063>>13725000
         ELSE                                                  <<07063>>13730000
            BEGIN   << File complete, ensure it has space.  >> <<07063>>13735000
            IF RECOVER'DISC'SPACE THEN                         <<07063>>13740000
               BEGIN   << Must reallocate its space.        >> <<07063>>13745000
               IF NOT GET'SPOOFLE'DISC'SPACE (XDD'SUBENTRY)    <<07063>>13750000
                      THEN                                     <<07063>>13755000
                  BEGIN   << Couldn't get the space.        >> <<07063>>13760000
                  MSG'PARM := "#I";                            <<07063>>13765000
                  LENGTH := ASCII (XDDS'DFID'NUMBER, 10,       <<07063>>13770000
                                   MSG'PARM'B(2));             <<07063>>13775000
                  MSG'PARM'B(LENGTH+2) := 0;  << Terminator >> <<07063>>13780000
                  GENMSG (SET1, MSG486, 0, @MSG'PARM'B);       <<W7791>>13785000
                  KILL'IT := TRUE;                             <<07063>>13790000
                  END;    << Couldn't get the space.        >> <<07063>>13795000
               END;    << Must reallocate its space.        >> <<07063>>13800000
            IF NOT KILL'IT AND XDDS'SPOOL'STATE = XDDS'OPEN    <<07063>>13805000
               THEN IF IDDS'RESTART THEN                       <<07063>>13810000
               BEGIN   << Was executing, should start over. >> <<07063>>13815000
               XDDS'SPOOL'STATE := XDDS'READY;                 <<07063>>13820000
               UPDATE'XDD := TRUE;                             <<07063>>13825000
               END                                             <<07063>>13830000
            ELSE                                               <<07063>>13835000
               BEGIN   << Was executing, don't start over.  >> <<07438>>13840000
               FNUM := FSOPEN ( , %305, %400, @XDD'ADDRESS);   <<07438>>13845000
               FSCLOSE (FNUM, DELETE, 0);                      <<07438>>13850000
                                                               <<07438>>13855000
<< Recompute size of IDD to allow for file purge.           >> <<07438>>13860000
                                                               <<07438>>13865000
               GET'XDD'SIZE (IDD'DST);                         <<07438>>13870000
                                                               <<07438>>13875000
<< Make sure we don't count this spool file space.          >> <<07063>>13880000
                                                               <<07063>>13885000
               XDDS'NUMBER'EXTENTS := 1;                       <<07063>>13890000
               XDDS'LAST'EXTENT'SIZE := 0;                     <<07063>>13895000
               END;    << Was executing, don't start over.  >> <<07063>>13900000
            END;    << File complete, ensure it has space.  >> <<07063>>13905000
         END;    << A spool file, what do we do with it?    >> <<07063>>13910000
      IF UPDATE'XDD THEN                                       <<07063>>13915000
         BEGIN   << Subentry changed, post the changes.     >> <<07063>>13920000
         MOVETODSEG (IDD'DST, @XDD'ADDRESS, XDD'SUBENTRY,      <<07063>>13925000
                     XDD0'SUBENTRY'LENGTH);                    <<07063>>13930000
         WRITEDSEG (IDD'DST);                                  <<07063>>13935000
         END;                                                  <<07063>>13940000
      IF KILL'IT THEN                                          <<07063>>13945000
         BEGIN   << Remove subentry, recompute XDD size.    >> <<07438>>13950000
         SREMOVEXDD (XDD'ADDRESS);                             <<07438>>13955000
         GET'XDD'SIZE (IDD'DST);                               <<07438>>13960000
         END     << Remove subentry, recompute XDD size.    >> <<07438>>13965000
      ELSE TOTAL'SPOOL'SECTORS := TOTAL'SPOOL'SECTORS +        <<07438>>13970000
           (XDDS'NUMBER'EXTENTS - 1) ** EXTENT'SIZE +          <<07063>>13975000
           DOUBLE (XDDS'LAST'EXTENT'SIZE);                     <<07063>>13980000
      END;   << Entry is being used.                        >> <<07063>>13985000
   @XDD'ADDRESS := @XDD'ADDRESS + SIZE'OF'XDD'SUBENTRY;        <<07438>>13990000
   END;   << Check all IDD subentries.                      >> <<07063>>13995000
SET'UP'LDT (IDD'DST);                                          <<07063>>14000000
                                                               <<07063>>14005000
<<**********************************************************>> <<07063>>14010000
<<                                                          >> <<07063>>14015000
<<                   Recover the ODD here.                  >> <<07063>>14020000
<<                                                          >> <<07063>>14025000
<<**********************************************************>> <<07063>>14030000
                                                               <<07063>>14035000
<< See the comments in the IDD recovery section.            >> <<07438>>14040000
                                                               <<07063>>14045000
GET'XDD'SIZE (ODD'DST);                                        <<07438>>14050000
@XDD'ADDRESS := XDD0'SUBENTRY'AREA;                            <<07438>>14055000
WHILE @XDD'ADDRESS <= LAST'POSSIBLE'SUBENTRY DO                <<07438>>14060000
   BEGIN   << Check all ODD subentries.                     >> <<07063>>14065000
   KILL'IT := UPDATE'XDD := CAN'T'RECOVER := FALSE;            <<07063>>14070000
   MOVEFROMDSEG (XDD'SUBENTRY, ODD'DST, @XDD'ADDRESS,          <<07063>>14075000
                 XDD0'SUBENTRY'LENGTH);                        <<07063>>14080000
   IF XDD'SUBENTRY <> XDDS'UNUSED'SUBENTRY THEN                <<07063>>14085000
      BEGIN   << Entry is being used.                       >> <<07063>>14090000
      IF XDDSD'DISC'LABEL = 0D THEN                            <<07063>>14095000
         KILL'IT := TRUE   << Not a spool file.             >> <<07063>>14100000
      ELSE                                                     <<07063>>14105000
         BEGIN   << A spool file, what do we do with it?    >> <<07063>>14110000
         IF XDDS'SPOOL'STATE = XDDS'OPEN THEN                  <<07063>>14115000
            BEGIN   << File is incomplete, we have to work. >> <<07063>>14120000
            IF FIX'OPEN'OUTPUT'SPOOFLE (XDD'SUBENTRY) THEN     <<B7518>>14125000
               UPDATE'XDD := TRUE                              <<B7518>>14130000
            ELSE CAN'T'RECOVER := TRUE;                        <<B7518>>14135000
            END;                                               <<07063>>14140000
                                                               <<07063>>14145000
<< If the file was open and was properly fixed  (above)  it >> <<07063>>14150000
<< should  now  look like a vanilla READY file.  This means >> <<07063>>14155000
<< the code below now gets a chance at it.                  >> <<07063>>14160000
                                                               <<07063>>14165000
         IF NOT CAN'T'RECOVER THEN                             <<07063>>14170000
            BEGIN   << File complete, ensure it has space.  >> <<07063>>14175000
            IF XDDS'SPOOL'STATE <> XDDS'READY THEN             <<07063>>14180000
               BEGIN                                           <<07063>>14185000
               XDDS'SPOOL'STATE := XDDS'READY;                 <<07063>>14190000
               UPDATE'XDD := TRUE;                             <<07063>>14195000
               END;                                            <<07063>>14200000
            IF RECOVER'DISC'SPACE THEN                         <<07063>>14205000
               IF NOT GET'SPOOFLE'DISC'SPACE (XDD'SUBENTRY)    <<07063>>14210000
                  THEN CAN'T'RECOVER := TRUE;                  <<07063>>14215000
            END;    << File complete, ensure it has space.  >> <<07063>>14220000
         END;    << A spool file, what do we do with it?    >> <<07063>>14225000
      IF CAN'T'RECOVER THEN                                    <<07063>>14230000
         BEGIN   << Couldn't put Humpty-Dumpty together.    >> <<07063>>14235000
         MSG'PARM := "#O";                                     <<07063>>14240000
         LENGTH := ASCII (XDDS'DFID'NUMBER, 10, MSG'PARM'B(2));<<07063>>14245000
         MSG'PARM'B(LENGTH+2) := 0;   << Terminator.        >> <<07063>>14250000
         GENMSG (SET1, MSG486, 0, @MSG'PARM'B);                <<W7791>>14255000
         KILL'IT := TRUE;                                      <<07063>>14260000
         UPDATE'XDD := FALSE;                                  <<07063>>14265000
         END;    << Couldn't put Humpty-Dumpty together.    >> <<07063>>14270000
      IF UPDATE'XDD THEN                                       <<07063>>14275000
         BEGIN   << Subentry changed, post the changes.     >> <<07063>>14280000
         MOVETODSEG (ODD'DST, @XDD'ADDRESS, XDD'SUBENTRY,      <<07063>>14285000
                     XDD0'SUBENTRY'LENGTH);                    <<07063>>14290000
         WRITEDSEG (ODD'DST);                                  <<07063>>14295000
         END;                                                  <<07063>>14300000
      IF KILL'IT THEN                                          <<07063>>14305000
         BEGIN   << Remove the subentry from the ODD.       >> <<07063>>14310000
         TOS := @XDD'ADDRESS;   << Must do it this way...   >> <<07063>>14315000
         TOS.(0:1) := 1;         << ...to fool SPL.         >> <<07063>>14320000
         SREMOVEXDD (*);                                       <<07063>>14325000
         GET'XDD'SIZE (ODD'DST);                               <<07438>>14330000
         END                                                   <<07063>>14335000
      ELSE TOTAL'SPOOL'SECTORS := TOTAL'SPOOL'SECTORS +        <<07063>>14340000
           (XDDS'NUMBER'EXTENTS - 1) ** EXTENT'SIZE +          <<07063>>14345000
           DOUBLE (XDDS'LAST'EXTENT'SIZE);                     <<07063>>14350000
      END;    << Entry is being used.                       >> <<07063>>14355000
   @XDD'ADDRESS := @XDD'ADDRESS + SIZE'OF'XDD'SUBENTRY;        <<07438>>14360000
   END;    << Check all ODD subentries.                     >> <<07063>>14365000
SET'UP'LDT (ODD'DST);                                          <<07063>>14370000
RAISE'OUTFENCE;                                                <<07438>>14375000
TOS := TOTAL'SPOOL'SECTORS;   << Put recovered current...   >> <<07063>>14380000
SYSCURSPKSEC2 := TOS;         << ...spool file sector...    >> <<07063>>14385000
SYSCURSPKSEC1 := TOS;         << ...count in SYSGLOB.       >> <<07063>>14390000
END;   << of RECOVER'XDD.                                   >> <<07063>>14395000
$PAGE  "INITSPOOLING"                                          <<07063>>14400000
$CONTROL SEGMENT = SPOOLCOMS1                                  <<07063>>14405000
                                                                        14410000
                                                                        14415000
PROCEDURE INITSPOOLING;                                                 14420000
   OPTION PRIVILEGED, UNCALLABLE;                                       14425000
BEGIN                                                                   14430000
   INTEGER           DEVICE,                                   <<06744>>14435000
                     LDT'INDEX := 0;                           <<07438>>14440000
   LOGICAL ARRAY     LDT(0:SIZE'OF'LDT'ENTRY - 1);             <<07438>>14445000
   INTEGER           ACTION;           <<INITIATESPOOLER ACTION>>       14450000
   EQUATE            OKAY = 0,                                          14455000
                     NOTSPOOLEE = 3,                                    14460000
                     NOTJD = 4;                                         14465000
   DOUBLE            X1  := "SPOO";    << "SPOOL" CLASS NAME >>         14470000
   INTEGER           X2  := %46015;                                     14475000
   BYTE ARRAY        SPOOL (*) = X1;                                    14480000
   INTEGER ARRAY     DEVINFO (0:SIZE'OF'GETDEVINFO);           <<06744>>14485000
                                                                        14490000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07438>>14495000
SUBROUTINE DEF'MOVETODSEG;                                     <<07438>>14500000
                                                                        14505000
<< >>                                                                   14510000
   IF GETDEVINFO (SPOOL, DEVINFO) = 0                                   14515000
         AND IT'S'A'DISC (G'ACCESS'TYPE) THEN                  <<06744>>14520000
      TOS := G'DCT'INDEX                                       <<06744>>14525000
   ELSE                                                                 14530000
      TOS := 0;                                                         14535000
   SYSSPOOLDCTINDX := TOS;     << "SPOOL" CLASS INDEX (NEG) >> <<07438>>14540000
   DEVICE := 1;                                                         14545000
   DO BEGIN   << This loop processes one LDEV.              >> <<07438>>14550000
      MOVEFROMDSEG (LDT, LDT'DST, DEVICE * SIZE'OF'LDT'ENTRY,  <<07438>>14555000
                    SIZE'OF'LDT'ENTRY);                        <<07438>>14560000
      IF (LDT'SPOOL'STATE <> LDT'NOT'SPOOLED) THEN             <<06744>>14565000
         BEGIN   << Spooled device, start its spooler.      >> <<07438>>14570000
         ACTION := INITIATESPOOLER (DEVICE, LDT'SPOOL'STATE    <<06744>>14575000
               &LSR(1) + LDT'SPOOL'QUEUES &LSL(1));            <<06744>>14580000
         IF ACTION <> OKAY THEN                                         14585000
            IF (ACTION = NOTSPOOLEE)  OR  (ACTION = NOTJD)  THEN        14590000
               BEGIN                                                    14595000
               GENMSG(1,241,%10000,DEVICE,,,,,0);              <<00.EB>>14600000
               LDT'SPOOL'STATE := LDT'NOT'SPOOLED;             <<06744>>14605000
               LDT'SPOOL'QUEUES := LDT'QSHUT;                  <<06744>>14610000
               MOVETODSEG (LDT'DST, DEVICE * SIZE'OF'LDT'ENTRY,<<07438>>14615000
                           LDT, SIZE'OF'LDT'ENTRY);            <<07438>>14620000
               END                                                      14625000
            ELSE                                                        14630000
               SUDDENDEATH (370);                                       14635000
         END;    << Spooled device, start its spooler.      >> <<07438>>14640000
      END     << This loop processes one LDEV.              >> <<07438>>14645000
   UNTIL (DEVICE := DEVICE +1) > INTEGER (LPDT'MAX'ENTRIES);   <<07438>>14650000
                                                               <<06915>>14655000
   << open spool queues for NRJE card readers >>               <<06915>>14660000
   NRJEOPENQS;                                                 <<06915>>14665000
   END;    <<INITSPOOLING>>                                             14670000
$PAGE "   ***   DEVICE/CLASS DISPLAY (UTILITY)   ***"                   14675000
$CONTROL SEGMENT= SPOOLCOMS2                                            14680000
                                                                        14685000
                                                                        14690000
INTEGER PROCEDURE DEVSPEC (DEVICE, BUFB);                               14695000
   VALUE DEVICE;                                                        14700000
   INTEGER DEVICE;                                                      14705000
   BYTE ARRAY BUFB;                                                     14710000
   OPTION PRIVILEGED, UNCALLABLE;                                       14715000
BEGIN                                                                   14720000
  COMMENT -- Returns ASCII string of LDEV (DEVICE >= 0) or de- <<07438>>14725000
vice class (DEVICE < 0) in BUFB, length of string in result.   <<07438>>14730000
;                                                              <<07438>>14735000
LOGICAL                                                        <<07438>>14740000
   CLASS'ADDRESS;   << Offset of desired class entry in DCT >> <<07438>>14745000
                                                               <<07438>>14750000
LOGICAL ARRAY                                                  <<07438>>14755000
   LOCAL'BUF(0:4);   << Extra word holds delimiting blanks. >> <<07438>>14760000
                                                               <<07438>>14765000
BYTE ARRAY                                                     <<07438>>14770000
   LOCAL'BUFB(*) = LOCAL'BUF;                                  <<07438>>14775000
                                                               <<07438>>14780000
                                                               <<07438>>14785000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07438>>14790000
<< >>                                                                   14795000
   IF DEVICE >= 0 THEN                                                  14800000
      DEVSPEC := ASCII (DEVICE, 10, BUFB)                      <<07438>>14805000
   ELSE                                                                 14810000
      BEGIN    <<FIND CLASS>>                                           14815000
      LOCAL'BUF := "  ";                                       <<07438>>14820000
      MOVE LOCAL'BUF(1) := LOCAL'BUF, (4);                     <<07438>>14825000
      GET'DEVICE'CLASS (-DEVICE, CLASS'ADDRESS);               <<07438>>14830000
      MOVEFROMDSEG (LOCAL'BUF, DCT'DST, CLASS'ADDRESS, 4);     <<07438>>14835000
      MOVE BUFB := LOCAL'BUFB WHILE AN, 1;                     <<07438>>14840000
      DEVSPEC := TOS - @BUFB;                                  <<07438>>14845000
      END;     << Find class.                               >> <<07438>>14850000
   END;    <<DEVSPEC>>                                                  14855000
$PAGE "Procedure SHOWFILES - global declarations"              <<07438>>14860000
INTEGER PROCEDURE SHOWFILES (PARMSTRING, PARMNUM, INJOBNUM, OUT);       14865000
   VALUE INJOBNUM, OUT;                                                 14870000
   BYTE ARRAY PARMSTRING;                                               14875000
   INTEGER PARMNUM, INJOBNUM;                                           14880000
   LOGICAL OUT;                                                         14885000
   OPTION PRIVILEGED, UNCALLABLE;                                       14890000
BEGIN                                                                   14895000
                                                                        14900000
<< DECLARATIONS >>                                                      14905000
                                                                        14910000
<< PARSE >>                                                             14915000
   EQUATE             MAXPARMS = 12;                           <<U.RAO>>14920000
   P'DECLARATIONS;                                                      14925000
   EQUATE            STATESTART  = 66,                                  14930000
                     KEYLEN  = ((STATESTART +1) /2) +12;                14935000
   BYTE ARRAY        KEYWORDSP (*) = PB :=                              14940000
                        6, 3, "DEV", 1,                                 14945000
                        6, 3, "JOB", 2,                                 14950000
                        10, 6, "ACTIVE", 3, XDDS'ACTIVE,       <<06744>>14955000
                        9, 5, "READY", 3, XDDS'READY,          <<06744>>14960000
                        10, 6, "OPENED", 3, XDDS'OPEN,         <<06744>>14965000
                        10, 6, "LOCKED", 3, XDDS'LOCKED,       <<06744>>14970000
                        9, 6, "STATUS", 4,                              14975000
                        5, 2, "SP", 5,                                  14980000
                        0,                                              14985000
                        << STATES >>                                    14990000
                        "ACTIVE",                                       14995000
                        "READY ",                                       15000000
                        "OPENED",                                       15005000
                        "LOCKED";                                       15010000
   ARRAY             KEYWORDSPW (*) = KEYWORDSP;                        15015000
   ARRAY             KEYWORDSW (0:KEYLEN-1);                            15020000
   BYTE ARRAY        KEYWORDS (*) = KEYWORDSW;                          15025000
   BYTE POINTER      KEYDEFN;                                           15030000
                                                                        15035000
<< VARIABLES CONTROLLING SCANNING: RESULTING FROM PARSE >>              15040000
   EQUATE            NODEV = 0;                                <<07438>>15045000
   INTEGER           DFID := 0,        <<DEV FILE ID; OR 0 (ALL)>>      15050000
                     DEV := NODEV;  <<+DEV/-CLASS INDEX     >> <<07438>>15055000
   INTEGER ARRAY     DEVINFO (0:SIZE'OF'GETDEVINFO)=Q;         <<06744>>15060000
   INTEGER           JOBNUM := 0;      <<JOB NUM QUALIFIER>>            15065000
   EQUATE            NOSTATE = 4;      <<NO STATE SPEC SIGNAL>>         15070000
   INTEGER           STATE := NOSTATE; <<STATE QUALIFIER>>              15075000
   EQUATE            NODEF = 0,        <<DEFERRED SPECIFICATION>>       15080000
                     NONDEFR = 2,                                       15085000
                     DEFR = 1;                                          15090000
   INTEGER           DEF := NODEF;                                      15095000
INTEGER JPRIME := 0;                                           <<U.RAO>>15100000
   LOGICAL           SP := FALSE,      <<JUST SPOOFLES REQUEST>>        15105000
                     STATUS := FALSE;  <<JUST "STATUS" REQUEST>>        15110000
   EQUATE ERRORMAX = 3;                                        <<U.RAO>>15115000
   INTEGER ERRORCOUNT := 0;                                    <<U.RAO>>15120000
   LOGICAL FLAGS := 0;                                         <<U.RAO>>15125000
   DEFINE DEVFLAG = FLAGS.(15:1)#,                             <<U.RAO>>15130000
          JOBFLAG = FLAGS.(14:1)#,                             <<U.RAO>>15135000
          STATEFLAG = FLAGS.(13:1)#,                           <<U.RAO>>15140000
          STATUSFLAG = FLAGS.(12:1)#,                          <<U.RAO>>15145000
          SPOOFLESFLAG = FLAGS.(11:1)#,                        <<U.RAO>>15150000
          ALLFLAG = FLAGS.(0:1)#;                              <<U.RAO>>15155000
                                                                        15160000
<< VARIABLES FOR SCAN >>                                                15165000
   LOGICAL POINTER   LASTHEADP,        <<LAST HEAD TO EXAMINE>><<07438>>15170000
                     CLASS'XDD'HEADS,  << XDD hd indx array >> <<07438>>15175000
                     XDD'CLASS'INDICES;<< All XDD cls indxs >> <<07438>>15180000
                                                               <<06744>>15185000
   << Local arrays for use with the XDD INCLUDE file.       >> <<07438>>15190000
   LOGICAL ARRAY     XDD(0:SIZE'OF'XDD0-1),                    <<07438>>15195000
                     XDD'HEAD(0:SIZE'OF'XDD'HEAD-1),           <<07438>>15200000
                     XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY-1);   <<07438>>15205000
   BYTE ARRAY        XDD'BSUBENTRY(*) = XDD'SUBENTRY;          <<07438>>15210000
                                                               <<06744>>15215000
   LOGICAL           CLASS'ADDRESS,  << DCT adr of cls indx >> <<07438>>15220000
                     FOUND'ONE,      << Table search flag.  >> <<07438>>15225000
                     HAVE'SUBENTRY,  << Nxt subentry exists >> <<07438>>15230000
                     HEAD'ENTRY'OFFSET,   << In XDD.        >> <<07438>>15235000
                     SUBENTRY'OFFSET,     << Also in XDD.   >> <<07438>>15240000
                     XDD'DST,        <<DATA SEG OF XDD>>       <<07438>>15245000
                     XDD'LDEV;       <<LDEV OF SUBENTRY>>      <<06744>>15250000
                                                               <<06744>>15255000
   LOGICAL POINTER   DCT;              <<DCT TABLE POINTER>>   <<06744>>15260000
   INTEGER           CLASS'LENGTH,     << DCT entry length. >> <<07438>>15265000
                     CURRENT'CLASS'INDEX,                      <<07438>>15270000
                     CURRENT'DEV'INDEX,                        <<07438>>15275000
                     NUMDEVS,          << # devices in cls. >> <<07438>>15280000
                     NUM'XDD'CLASSES,                          <<07438>>15285000
                     QDSDEVICE,        << For DSDEVICE.     >> <<07438>>15290000
                     QLDEV;            << For DSDEVICE.     >> <<07438>>15295000
                                                               <<06744>>15300000
   << TEMPORARY CELL FOR RANK >>                               <<06744>>15305000
   DEFINE            OD'RANK = XDDS'NEXT'SUBENTRY#;            <<06744>>15310000
   INTEGER           RANK := 0;        <<ODD RANK ACCUMULATOR>>         15315000
   INTEGER           XDDSIR,           <<APPROPRIATE SIR>>              15320000
                     SAVESIR;          <<GETSIR RESULT>>                15325000
   INTEGER           LDT'INDEX := 0;   <<LDT INDEX POINTER>>   <<07438>>15330000
   LOGICAL ARRAY     LDT(0:SIZE'OF'LDT'ENTRY-1);               <<07438>>15335000
                                                                        15340000
<< VARIABLES FOR SUMMARY ACCUMULATION >>                                15345000
   INTEGER           ST;               <<TEMPORARY>>                    15350000
   << FOLLOWING DECLARATIONS MUST REMAIN DIRECT (=Q) AND CONTIG 4 INIT>>15355000
   INTEGER ARRAY     STCOUNTS (0:3) =Q, <<(TOTAL) STATE COUNTS>>        15360000
                     DEFCOUNTS (0:3) =Q,<<DEFERRED COUNTS (/STATE)>>    15365000
                     SPCOUNTS (0:3) =Q; <<SPOOFLE COUNTS (/STATE)>>     15370000
   DOUBLE            SPSPACE := 0D;    <<SPOOFLE SPACE>>                15375000
   INTEGER           TOTAL;                                             15380000
                                                                        15385000
<< FOR VISIT OF EACH ENTRY >>                                           15390000
   INTEGER           DUMMY;                                    <<S8106>>15395000
   INTEGER           SAVELINK;         <<SAVED LINK WD ('CAUSE <RANK>)>>15400000
                                                               <<00548>>15405000
<< VARIABLES FOR EXTRA DATA SEG -- SEQUENTIAL READ/WR ACCESS>> <<00548>>15410000
   INTEGER           DSTNUM := 0,      <<0 => NOT ACQUIRED>>   <<00548>>15415000
                     ERRNUM := 0;      <<DST ERR?>>            <<00548>>15420000
   LOGICAL           NEXTLOC,                                  <<00548>>15425000
                     ENDOFDATA ,       <<# OF WORDS USED>>     <<00548>>15430000
                     DSTLENGTH;                                <<00548>>15435000
                                                                        15440000
<< PRINT VARIABLES >>                                          <<00548>>15445000
   EQUATE            OBUFMAX = 32;                             <<00548>>15450000
   ARRAY             OBUF (0:OBUFMAX); <<OUTPUT BUFFER>>       <<00548>>15455000
   BYTE ARRAY        OBUFB (*) = OBUF;                                  15460000
   BYTE ARRAY        STATES (*)  = KEYWORDS (STATESTART);               15465000
   BYTE ARRAY        SPACEBUF (0:11);  <<2 GET RT. JUSTIFICATION>>      15470000
   LOGICAL           STOP  := FALSE;   <<FSYS ERROR INDICATOR>>         15475000
   INTEGER           LEN;              <<PRINT LEN (IN BYTES)>>         15480000
   EQUATE            HEADERLEN = -61;                                   15485000
   EQUATE            POSDEVCL = 0,                                      15490000
                     POSDFID = POSDEVCL +9,                             15495000
                     POSJNUM = POSDFID +8,                              15500000
                     POSJNAME = POSJNUM,                                15505000
                     POSFNAME = POSJNUM +8,                             15510000
                     POSSTATE = POSFNAME +9,                            15515000
                     POSFORMS = POSSTATE +7,                            15520000
                     POSSPACE = POSFORMS +8,                            15525000
                     POSRANK = POSSPACE +4,                             15530000
                     POSDEFPRI = POSRANK +1,                            15535000
                     POSNUMC = POSDEFPRI +6;                            15540000
                                                                        15545000
                                                                        15550000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07438>>15555000
                                                               <<07438>>15560000
                                                               <<07438>>15565000
SUBROUTINE DEF'MOVETODSEG;                                     <<07438>>15570000
                                                               <<07438>>15575000
                                                               <<07438>>15580000
SUBROUTINE DEF'MOVEDSEG;                                       <<07438>>15585000
$PAGE "Procedure SHOWFILES - subroutines COUNT'ERROR, ERROR"   <<S8106>>15590000
SUBROUTINE COUNT'ERROR (ERRN);                                 <<S8106>>15595000
   VALUE   ERRN;                                               <<S8106>>15600000
   INTEGER ERRN;                                               <<S8106>>15605000
                                                               <<S8106>>15610000
BEGIN COMMENT --                                               <<S8106>>15615000
  This code has been moved here from ERROR  so  that  code  in <<S8106>>15620000
PARSEDEV which calls CIERR can finish the error monitoring re- <<S8106>>15625000
quired by SHOWFILES.  The interface to ERROR is not changed.   <<S8106>>15630000
;                                                              <<S8106>>15635000
IF ERRN > 0 THEN   << CI error, not a warning.              >> <<S8106>>15640000
   BEGIN   << Have to monitor the errors.                   >> <<S8106>>15645000
   SHOWFILES := ERRN;                                          <<S8106>>15650000
   PARMNUM := PNUM + PARMNUM;                                  <<S8106>>15655000
   ERRORCOUNT := ERRORCOUNT + 1;                               <<S8106>>15660000
   IF ERRORCOUNT > ERRORMAX THEN   << Too many errors...    >> <<S8106>>15665000
      BEGIN                        << ... stop parsing.     >> <<S8106>>15670000
      STOP := TRUE;                                            <<S8106>>15675000
      CIERR (-SHOWF2MERRORS, PP);                              <<S8106>>15680000
      END;    << Stop parsing.                              >> <<S8106>>15685000
   END;    << Have to monitor the errors.                   >> <<S8106>>15690000
END;    << of COUNT'ERROR.                                  >> <<S8106>>15695000
                                                               <<S8106>>15700000
                                                               <<S8106>>15705000
                                                               <<S8106>>15710000
SUBROUTINE ERROR (ERRN);                                                15715000
   VALUE ERRN;                                                          15720000
   INTEGER ERRN;                                                        15725000
<< CALLED WHEN ERROR <ERRN> DETECTED.  SETS RETURN PARAMETERS:          15730000
   SHOWFILES (TO <ERRN>), AND <PARMNUM> (TO <PNUM>); AND                15735000
   DECIDES WHETHER TO CALL CIERR OR EXIT.>>                    <<U.RAO>>15740000
BEGIN                                                          <<U.RAO>>15745000
CIERR (ERRN, PP);                                              <<S8106>>15750000
COUNT'ERROR (ERRN);                                            <<S8106>>15755000
END;  <<SUBROUTINE ERROR>>                                     <<U.RAO>>15760000
$PAGE "Procedure SHOWFILES - subroutine FATALERROR"            <<07438>>15765000
SUBROUTINE FATALERROR;  <<FATAL ERROR, INCIDENTALLY>>          <<00548>>15770000
BEGIN COMMENT --                                               <<S8106>>15775000
  The conditional FREEDSEG must be done as  shown.  You  can't <<S8106>>15780000
replace  the  EXIT  below with GO TO LEAVE because we will not <<S8106>>15785000
return from CIERR if :SHOWxxx was called in a job  stream  but <<S8106>>15790000
was not preceded by :CONTINUE.                                 <<S8106>>15795000
;                                                              <<S8106>>15800000
IF DSTNUM <> 0 THEN FREEDSEG (DSTNUM, 0);                      <<S8106>>15805000
CIERR(SHOWFILES := ERRNUM);                                    <<01152>>15810000
ASSEMBLE(EXIT 4);  << FATAL ERROR, BAIL OUT >>                 <<01152>>15815000
END;                                                           <<U.RAO>>15820000
$PAGE "Procedure SHOWFILES - subroutine GETNEXT"               <<07438>>15825000
SUBROUTINE GETNEXT;                                            <<U.RAO>>15830000
BEGIN   <<EXTRACTS NEXT PARAMETER>>                            <<U.RAO>>15835000
IF PNUM+1 = MAXPARMS THEN  <<NEED A NEW SET OF PARMS>>         <<U.RAO>>15840000
   BEGIN                                                       <<U.RAO>>15845000
   MYCOMMAND(PP,,MAXPARMS, NUMPARMS, PARMS(1));                <<U.RAO>>15850000
   PNUM := 1;                                                  <<U.RAO>>15855000
   PARMNUM := PARMNUM+MAXPARMS-1;                              <<U.RAO>>15860000
   END;                                                        <<U.RAO>>15865000
PARM := PARMS(PNUM := PNUM+1);                                 <<U.RAO>>15870000
END;                                                           <<U.RAO>>15875000
$PAGE "Procedure SHOWFILES - subroutine DSDEVICE"              <<07438>>15880000
LOGICAL SUBROUTINE DSDEVICE(LDEV);                             <<01906>>15885000
   VALUE LDEV;                                                 <<07438>>15890000
   INTEGER LDEV;                                               <<07438>>15895000
BEGIN                                                          <<01906>>15900000
  COMMENT -- This subroutine roots out any DS devices the user <<07438>>15905000
may have specified, either by LDEV or by device class,  so  we <<07438>>15910000
can  slap his/her hands for it.  The reason is that under X.25 <<07438>>15915000
protocol, a DS device may exist only in a file (database),  so <<07438>>15920000
we would not be able to find it in any MPE tables.             <<07438>>15925000
  Implementation note:  if we're passed a Device  Class  Table <<07438>>15930000
index,  we  have to examine the DCT entry, which is of unknown <<07438>>15935000
length.  Thus we must build a stack-relative array to hold the <<07438>>15940000
entry.  This is tricky anywhere, but in  a  subroutine  it  is <<07438>>15945000
doubly dangerous because the return address and any parameters <<07438>>15950000
are S-relative.  We get around the problem  by  sticking  both <<07438>>15955000
the parameter and the working result in Q-relative cells while <<07438>>15960000
we play games with the stack.  Before exiting we make sure  we <<07438>>15965000
remove all the stack space we put  on  earlier.  Future  main- <<07438>>15970000
tainers, take note!                                            <<07438>>15975000
;                                                              <<07438>>15980000
QLDEV := LDEV;   << Store S-relative parm in Q-rel cell.    >> <<07438>>15985000
SAVESIR := GETSIR (DCT'SIR);                                   <<07438>>15990000
QDSDEVICE := TRUE;                                             <<07438>>15995000
IF QLDEV > 0 THEN                                              <<07438>>16000000
   BEGIN                                                       <<07438>>16005000
   IF GET'DSDEVICE (QLDEV) <> 2 THEN                           <<07438>>16010000
      QDSDEVICE := FALSE;                                      <<07438>>16015000
   END                                                         <<07438>>16020000
ELSE IF QLDEV < 0 THEN                                         <<S8106>>16025000
   BEGIN   << Device class.                                 >> <<07438>>16030000
   CLASS'LENGTH := GET'DEVICE'CLASS (-QLDEV, CLASS'ADDRESS);   <<07438>>16035000
   PUSH (S);                                                   <<07438>>16040000
   @DCT := TOS + 1;                                            <<07438>>16045000
   TOS := CLASS'LENGTH;                                        <<07438>>16050000
   ASSEMBLE (ADDS 0);                                          <<07438>>16055000
   MOVEFROMDSEG (DCT, DCT'DST, CLASS'ADDRESS, CLASS'LENGTH);   <<07438>>16060000
   NUMDEVS := DCT'NUM'DEVICES;                                 <<07438>>16065000
   WHILE (NUMDEVS := NUMDEVS - 1) >= 0 DO                      <<07438>>16070000
      BEGIN   << Fail if any LDEV in class is a DS device.  >> <<07438>>16075000
      IF GET'DSDEVICE (DCT(DCT'FIRST'LDEV+NUMDEVS)) = 2 THEN   <<07438>>16080000
         NUMDEVS := 0   << Stop loop, report TRUE.          >> <<07438>>16085000
      ELSE IF NUMDEVS = 0 THEN QDSDEVICE := FALSE;             <<07438>>16090000
      END;    << Fail if any LDEV in class is a DS device.  >> <<07438>>16095000
   TOS := CLASS'LENGTH;   << Cut stack back again here.     >> <<07438>>16100000
   ASSEMBLE (SUBS 0);                                          <<07438>>16105000
   END;    << Device class.                                 >> <<07438>>16110000
                                                               <<S8106>>16115000
<< If QLDEV = 0, GETDEVINFO said it was a DS device so just >> <<S8106>>16120000
<< return TRUE.                                             >> <<S8106>>16125000
                                                               <<S8106>>16130000
RELSIR (DCT'SIR, SAVESIR);                                     <<07438>>16135000
DSDEVICE := QDSDEVICE;                                         <<07438>>16140000
END;  << SUBROUTINE DSDEVICE >>                                <<01906>>16145000
$PAGE "Procedure SHOWFILES - subroutine PARSEDEV"              <<07438>>16150000
SUBROUTINE PARSEDEV;                                           <<U.RAO>>16155000
BEGIN   <<PARSES DEV PARAMETER, OF FORM   >>                   <<U.RAO>>16160000
<<                                        >>                   <<U.RAO>>16165000
<<   DEV={device/device class}            >>                   <<U.RAO>>16170000
<<                                        >>                   <<U.RAO>>16175000
IF PDEL <> EQUAL THEN                                          <<U.RAO>>16180000
   ERROR(SHOWFXPCTDEV)                                         <<U.RAO>>16185000
ELSE                                                           <<U.RAO>>16190000
   BEGIN  <<HAVE = SIGN>>                                      <<U.RAO>>16195000
   GETNEXT;    <<GET SUBPARAMETER>>                            <<U.RAO>>16200000
   IF PLEN=0 THEN                                              <<U.RAO>>16205000
      ERROR(SHOWFXPCTDEV)                                      <<U.RAO>>16210000
   ELSE                                                        <<S8106>>16215000
      BEGIN   << Some string specified.                     >> <<S8106>>16220000
                                                               <<S8106>>16225000
  COMMENT -- The test below has been modified because the pre- <<S8106>>16230000
vious test used to rely exclusively on  GETDEVINFO,  which  is <<S8106>>16235000
deficient in at least two respects:                            <<S8106>>16240000
1.  For an LDEV call, only the first three digits are examined <<S8106>>16245000
    (and this can't be changed without introducing compatibil- <<S8106>>16250000
    ity problems elsewhere). Thus for something like DEV=10000 <<S8106>>16255000
    GETDEVINFO will only see DEV=100.  If that LDEV exists, no <<S8106>>16260000
    error is reported. Also, the string DEV=6AB will be parsed <<S8106>>16265000
    as 6, and will again succeed if LDEV 6 exists.             <<S8106>>16270000
2.  For a device class call, any special character  terminates <<S8106>>16275000
    the class name.  Thus something like DEV=LP%%%%%%%%%%%..., <<S8106>>16280000
    clearly an error, will be parsed (successfully) as DEV=LP. <<S8106>>16285000
  The code below takes care of these special situations,  then <<S8106>>16290000
calls  GETDEVINFO  to  handle what's left.  The reason is that <<S8106>>16295000
other routines in SHOWFILES make use of DEVINFO,  so  we  must <<S8106>>16300000
assure its existence.                                          <<S8106>>16305000
;                                                              <<S8106>>16310000
      IF PP = NUMERIC THEN                                     <<S8106>>16315000
         BEGIN   << Numeric, check for valid real LDEV.     >> <<S8106>>16320000
         VERIFY'RLDEV (PP, PLEN, ERRNUM, DUMMY, PNUM);         <<S8106>>16325000
         IF < THEN                                             <<S8106>>16330000
            BEGIN   << Virtual LDEV, or not configured.     >> <<S8106>>16335000
            COUNT'ERROR (ERRNUM);   << CIERR already called >> <<S8106>>16340000
            GO EXIT'PARSEDEV;                                  <<S8106>>16345000
            END;    << Virtual LDEV, or not configured.     >> <<S8106>>16350000
         END     << Numeric, check for valid real LDEV.     >> <<S8106>>16355000
      ELSE                                                     <<S8106>>16360000
         BEGIN   << Not numeric, check for device class.    >> <<S8106>>16365000
         MOVE PP := PP WHILE AN, 1;                            <<S8106>>16370000
         IF S0 - @PP <> INTEGER (PLEN) AND BPS0 <> "#" THEN    <<S8106>>16375000
            BEGIN   << Invalid special chars in DEV spec.   >> <<S8106>>16380000
            ERROR (-SHOWFINVLDDEVSPEC);                        <<S8106>>16385000
            DEL;   << Clean up stack for subroutine exit.   >> <<S8106>>16390000
            GO EXIT'PARSEDEV;                                  <<S8106>>16395000
            END     << Invalid special chars in DEV spec.   >> <<S8106>>16400000
         ELSE DEL;                                             <<S8106>>16405000
         END;    << Not numeric, check for device class.    >> <<S8106>>16410000
      CASE GETDEVINFO (PP, DEVINFO) + 1 OF                     <<S8106>>16415000
        BEGIN   << Need GETDEVINFO for G'xxx references.    >> <<S8106>>16420000
                                                               <<S8106>>16425000
         ;   << -1, virtual LDEV, caught by VERIFY'RLDEV.   >> <<S8106>>16430000
                                                               <<S8106>>16435000
         ;   <<  0, no error.                               >> <<S8106>>16440000
                                                               <<S8106>>16445000
         ERRNUM := SHOWDVINVLDCLAS;  << Lifted from SHOWDEV >> <<S8106>>16450000
                                                               <<S8106>>16455000
         ERRNUM := SHOWDVNOSUCHCLS;  << This one too.       >> <<S8106>>16460000
                                                               <<S8106>>16465000
         ;   <<  3, invalid LDEV, caught by VERIFY'RLDEV.   >> <<S8106>>16470000
                                                               <<S8106>>16475000
        END;    << CASE statement.                          >> <<S8106>>16480000
      IF ERRNUM <> 0 THEN                                      <<S8106>>16485000
         BEGIN                                                 <<S8106>>16490000
         DUMMY := INTEGER (PP(PLEN));   << Save term. byte. >> <<S8106>>16495000
         PP(PLEN) := 0;  << CIERR parm need null terminator >> <<S8106>>16500000
         CIERR (-ERRNUM, PP, 1, @PP);                          <<S8106>>16505000
         PP(PLEN) := DUMMY;   << Replace original data.     >> <<S8106>>16510000
         GO EXIT'PARSEDEV;   << No COUNT'ERROR for CIWARNs  >> <<S8106>>16515000
         END;                                                  <<S8106>>16520000
      END;    << Some string specified.                     >> <<S8106>>16525000
   IF NOT OUT AND (G'DCT'INDEX < 0) THEN                       <<S8106>>16530000
      ERROR(SHOWFINPTDEVCLS)   <<DEVICE CLASS NOT ALLOWED ON IN<<U.RAO>>16535000
   ELSE IF G'ACCESS'TYPE <= 7 THEN                             <<06744>>16540000
      ERROR(SHOWFDACCESSDEV)   <<DIRECT ACCESS DEVICE NOT ALLOW<<U.RAO>>16545000
   ELSE IF DSDEVICE(G'DCT'INDEX) THEN                          <<06744>>16550000
      ERROR(SHOWFDSDEVICE)      <<DS DEVICE NOT ALLOWED >>     <<01906>>16555000
   ELSE   <<LOOKS FAIRLY GOOD>>                                <<U.RAO>>16560000
      BEGIN                                                    <<U.RAO>>16565000
      DEVFLAG := TRUE;                                         <<U.RAO>>16570000
      IF <> THEN   <<REDUNDANTLY SPECIFIED>>                   <<U.RAO>>16575000
         BEGIN                                                 <<U.RAO>>16580000
         PARM := PARMS(PNUM-1);  <<BACK UP TO "DEV">>          <<U.RAO>>16585000
         ERROR(-SHOWFRDNTDEV);                                 <<U.RAO>>16590000
         PARM := PARMS(PNUM);                                  <<U.RAO>>16595000
         END;                                                  <<U.RAO>>16600000
      DEV := G'DCT'INDEX;                                      <<06744>>16605000
      END;                                                     <<U.RAO>>16610000
                                                               <<S8106>>16615000
EXIT'PARSEDEV:                                                 <<S8106>>16620000
                                                               <<S8106>>16625000
   END;                                                        <<U.RAO>>16630000
END;   <<SUBROUTINE PARSEDEV>>                                 <<U.RAO>>16635000
                                                               <<U.RAO>>16640000
                                                               <<U.RAO>>16645000
$PAGE "Procedure SHOWFILES - subroutine PARSEJOB"              <<07438>>16650000
SUBROUTINE PARSEJOB;                                           <<U.RAO>>16655000
BEGIN   <<PARSES JOB PARAMETER, SYNTAX IS>>                    <<U.RAO>>16660000
<<                                                             <<U.RAO>>16665000
<<        @                                                    <<U.RAO>>16670000
<<  JOB = @J, @S, @J', @S'                                     <<U.RAO>>16675000
<<        #Jnnn, #Snnn, #J'nnn, #S'nnn, Jnnn, Snnn, J'nnn, S'nn<<U.RAO>>16680000
<<                                                             <<U.RAO>>16685000
<<Note that if an error is detected, the parser does its best t<<U.RAO>>16690000
<<figure out what the user wanted, and give him that or a super<<U.RAO>>16695000
<<of what he wanted.  For example, @J3 would result in an error<<U.RAO>>16700000
<<but we would still give the user @J.                         <<U.RAO>>16705000
                                                               <<U.RAO>>16710000
JOBFLAG := TRUE;                                               <<U.RAO>>16715000
IF <> THEN    <<REDUNDANTLY SPECIFIED>>                        <<U.RAO>>16720000
   ERROR (-SHOWFREDUNDJOB);                                    <<04833>>16725000
IF PDEL <> EQUAL THEN   <<MISSING EQUALS SIGN>>                <<U.RAO>>16730000
   BEGIN                                                       <<U.RAO>>16735000
   @PP := @PP+INTEGER(PLEN);                                   <<U.RAO>>16740000
   ERROR(SHOWFXPCTJOBEQ);                                      <<U.RAO>>16745000
   ALLFLAG := TRUE;                                            <<U.RAO>>16750000
   END                                                         <<U.RAO>>16755000
ELSE                                                           <<U.RAO>>16760000
   BEGIN   <<HAVE EQUAL SIGN, CHECK OUT SUBPARAMETER>>         <<U.RAO>>16765000
   GETNEXT;   <<GET SUBPARAMETER>>                             <<U.RAO>>16770000
   IF PLEN=0 THEN   <<MISSING SUBPARAMETER>>                   <<U.RAO>>16775000
      BEGIN                                                    <<U.RAO>>16780000
      ERROR(SHOWFXPCTJOB);                                     <<U.RAO>>16785000
      ALLFLAG := TRUE;                                         <<U.RAO>>16790000
      END                                                      <<U.RAO>>16795000
   ELSE   <<PARAMETER EXISTS, PARSE IT>>                       <<U.RAO>>16800000
      BEGIN                                                    <<U.RAO>>16805000
      ALLFLAG := FALSE;  <<INITIALIZE ALLFLAG>>                <<U.RAO>>16810000
      IF PP="@" THEN                                           <<U.RAO>>16815000
         BEGIN                                                 <<U.RAO>>16820000
         IF PP(1)="S" THEN                                     <<U.RAO>>16825000
            BEGIN                                              <<U.RAO>>16830000
            IF PLEN=3 AND PP(2)="'" THEN <<REINTRODUCED SPOOFLE<<U.RAO>>16835000
               JOBNUM := [2/0, 14/0]                           <<U.RAO>>16840000
            ELSE   <<REGULAR SESSIONS>>                        <<U.RAO>>16845000
               BEGIN                                           <<U.RAO>>16850000
               JOBNUM := [2/1, 14/0];   <<ALSO DEFAULT IF ERROR<<U.RAO>>16855000
               IF PLEN>2 THEN   <<EXTRA STUFF TACKED ON>>      <<U.RAO>>16860000
                  ERROR(SHOWFXPCTATS);                         <<U.RAO>>16865000
               END                                             <<U.RAO>>16870000
            END                                                <<U.RAO>>16875000
         ELSE IF PP(1)="J" THEN                                <<U.RAO>>16880000
            BEGIN                                              <<U.RAO>>16885000
            IF PLEN=3 AND PP(2)="'" THEN <<REINTRODUCED JOB SPO<<U.RAO>>16890000
               JOBNUM := [2/3, 14/0]                           <<U.RAO>>16895000
            ELSE   <<REGULAR JOB>>                             <<U.RAO>>16900000
               BEGIN                                           <<U.RAO>>16905000
               JOBNUM := [2/2, 14/0];                          <<U.RAO>>16910000
               IF PLEN>2 THEN   <<EXTRA STUFF, WARN AND IGNORE><<U.RAO>>16915000
                  ERROR(SHOWFXPCTATJ);                         <<U.RAO>>16920000
               END                                             <<U.RAO>>16925000
            END                                                <<U.RAO>>16930000
         ELSE   <<MUST BE @ OR @junk>>                         <<U.RAO>>16935000
            BEGIN                                              <<U.RAO>>16940000
            ALLFLAG := TRUE;                                   <<U.RAO>>16945000
            IF PLEN>1 THEN                                     <<U.RAO>>16950000
               BEGIN   <<EXTRA STUFF>>                         <<U.RAO>>16955000
               @PP := @PP+1;                                   <<U.RAO>>16960000
               ERROR(SHOWFUNKATX)                              <<U.RAO>>16965000
               END                                             <<U.RAO>>16970000
            END   <<PLAIN @ CASE>>                             <<U.RAO>>16975000
         END  <<ALL @ CASES>>                                  <<U.RAO>>16980000
      ELSE   <<A PARTICULAR JOB OR SESSION, EVIDENTLY>>        <<U.RAO>>16985000
         BEGIN                                                 <<U.RAO>>16990000
         IF PP="#" OR PP="J" OR PP="S" THEN                    <<U.RAO>>16995000
            BEGIN  <<LOOKS LIKE A SPECIFIC JOB #>>             <<U.RAO>>17000000
            JPRIME := 0;  <<REINITIALIZE IT>>                  <<U.RAO>>17005000
            IF PP="#" THEN                                     <<U.RAO>>17010000
               BEGIN                                           <<U.RAO>>17015000
               @PP := @PP+1;   <<MOVE PAST "#">>               <<U.RAO>>17020000
               PLEN := PLEN-1;                                 <<U.RAO>>17025000
               END;                                            <<U.RAO>>17030000
            IF PP="S" THEN   <<SESSIONS>>                      <<U.RAO>>17035000
               BEGIN                                           <<U.RAO>>17040000
               IF PP(1)="'" THEN   <<REINTRODUCED SESSION SPOOF<<U.RAO>>17045000
                  BEGIN                                        <<U.RAO>>17050000
                  JOBNUM.(0:2) := 0;                           <<U.RAO>>17055000
                  JPRIME := 1;                                 <<U.RAO>>17060000
                  END                                          <<U.RAO>>17065000
               ELSE   <<REGULAR SESSIONS>>                     <<U.RAO>>17070000
                  JOBNUM.(0:2) := 1;                           <<U.RAO>>17075000
              TOS:=BINARY(PP(1+JPRIME),INTEGER(PLEN)-1-JPRIME);<<U.RAO>>17080000
               IF <> OR NOT(1<=S0<=16383) THEN  <<PROBLEM>>    <<U.RAO>>17085000
                  BEGIN                                        <<U.RAO>>17090000
                  @PP := @PP+1+JPRIME;                         <<U.RAO>>17095000
                  ERROR(SHOWFXPCTSNUM);                        <<U.RAO>>17100000
                  DEL;  <<POP INVALID FILE NUMBER, >>          <<U.RAO>>17105000
                  TOS := 0;   <<DEFAULT TO ALL SESSIONS>>      <<U.RAO>>17110000
                  END;                                         <<U.RAO>>17115000
               JOBNUM.(2:14) := TOS;                           <<U.RAO>>17120000
               END <<PROCESSING OF SESSIONS>>                  <<U.RAO>>17125000
            ELSE IF PP="J" THEN  <<JOBS>>                      <<U.RAO>>17130000
               BEGIN                                           <<U.RAO>>17135000
               IF PP(1)="'" THEN   << REINTRODUCED JOB SPOOFLE><<U.RAO>>17140000
                  BEGIN                                        <<U.RAO>>17145000
                  JOBNUM.(0:2) := 3;                           <<U.RAO>>17150000
                  JPRIME := 1;                                 <<U.RAO>>17155000
                  END                                          <<U.RAO>>17160000
               ELSE   <<REGULAR JOBS>>                         <<U.RAO>>17165000
                  JOBNUM.(0:2) := 2;                           <<U.RAO>>17170000
              TOS:=BINARY(PP(1+JPRIME),INTEGER(PLEN)-1-JPRIME);<<U.RAO>>17175000
               IF <> OR NOT(1<=S0<=16383) THEN                 <<U.RAO>>17180000
                  BEGIN  <<INVALID FILE NUMBER>>               <<U.RAO>>17185000
                  @PP := @PP+1+JPRIME;                         <<U.RAO>>17190000
                  ERROR(SHOWFXPCTJNUM);                        <<U.RAO>>17195000
                  DEL;                                         <<U.RAO>>17200000
                  TOS := 0;                                    <<U.RAO>>17205000
                  END;                                         <<U.RAO>>17210000
               JOBNUM.(2:14) := TOS;                           <<U.RAO>>17215000
               END  <<JOB CASE>>                               <<U.RAO>>17220000
            ELSE  <<NOT JOB OR SESSION, ???>>                  <<U.RAO>>17225000
               BEGIN                                           <<U.RAO>>17230000
               ERROR(SHOWFXPCTJSNUM);                          <<U.RAO>>17235000
               ALLFLAG := TRUE;   <<DO ALL JOBS AND SESSIONS>> <<U.RAO>>17240000
               END                                             <<U.RAO>>17245000
            END                                                <<U.RAO>>17250000
         ELSE   <<NOT #, J, OR S>>                             <<U.RAO>>17255000
            BEGIN                                              <<U.RAO>>17260000
            ERROR(SHOWFXPCTJSNUM);                             <<U.RAO>>17265000
            ALLFLAG := TRUE;                                   <<U.RAO>>17270000
            END                                                <<U.RAO>>17275000
         END  <<PARTICULAR JOB CASE>>                          <<U.RAO>>17280000
      END  <<NON-NULL SUBPARAMETER CASE>>                      <<U.RAO>>17285000
   END;                                                        <<U.RAO>>17290000
END;  <<SUBROUTINE PARSEJOB>>                                  <<U.RAO>>17295000
$PAGE "Procedure SHOWFILES - subroutine PARSESTATE"            <<07438>>17300000
SUBROUTINE PARSESTATE;                                         <<U.RAO>>17305000
BEGIN                                                          <<U.RAO>>17310000
<<READY(,DEFERRED,NONDEFERRED), ACTIVE, LOCKED, OPENED>>       <<U.RAO>>17315000
IF (STATE <> NOSTATE) THEN                                     <<U.RAO>>17320000
   IF INTEGER(KEYDEFN(1)) <> STATE THEN <<INCONSISTENT SPECIFIC<<U.RAO>>17325000
      ERROR(-SHOWFREDNDSTATE);  <<OF STATES>>                  <<U.RAO>>17330000
STATE := KEYDEFN(1);                                           <<U.RAO>>17335000
DEF := NODEF;                                                  <<U.RAO>>17340000
IF PDEL = COMMA THEN   <<SUBPARAMETER SPECIFIED>>              <<U.RAO>>17345000
   BEGIN   <<EXPECTING EITHER N (NOT DEFFERED) OR D (DEFFERED) <<U.RAO>>17350000
   GETNEXT;   <<GET SUBPARAMETER>>                             <<U.RAO>>17355000
   IF NOT OUT THEN                                             <<U.RAO>>17360000
      ERROR(SHOWFINNDINAP)  <<INAPPROPRIATE FOR INPUT FILES>>  <<U.RAO>>17365000
   ELSE IF STATE<>XDDS'READY THEN<<VALID FOR READY OUTFILES>>  <<06744>>17370000
      ERROR(SHOWFOUTNDINAP)                                    <<U.RAO>>17375000
   ELSE IF PLEN=1 AND PP="N" THEN                              <<U.RAO>>17380000
      DEF := NONDEFR                                           <<U.RAO>>17385000
   ELSE IF PLEN=1 AND PP="D" THEN                              <<U.RAO>>17390000
      DEF := DEFR                                              <<U.RAO>>17395000
   ELSE   <<UNKNOWN TYPE, IGNORE>>                             <<U.RAO>>17400000
      ERROR(SHOWFUNKDEFR)                                      <<U.RAO>>17405000
   END;                                                        <<U.RAO>>17410000
END;   <<SUBROUTINE PARSESTATE>>                               <<U.RAO>>17415000
$PAGE "Procedure SHOWFILES - subroutine DEMAND"                <<07438>>17420000
INTEGER SUBROUTINE DEMAND (XDD'SUBENTRY);                      <<06744>>17425000
   VALUE XDD'SUBENTRY;                                         <<06744>>17430000
   LOGICAL POINTER XDD'SUBENTRY;                               <<06744>>17435000
<< DETERMINES "LOAD" THAT ODD SUBENTRY <ENTRYP> IMPOSES ON ITS          17440000
   ODD DEVICE/CLASS QUEUE.  I.E. HOW MUCH DOES/WILL THIS SUBENTRY       17445000
   DELAY FOLLOWING SUBENTRIES.  F (STATE, #COPIES, DEFERREDNESS,        17450000
   DEV/CL).  >>                                                         17455000
BEGIN                                                                   17460000
   DEMAND := 0;                                                         17465000
   COMMENT                                                     <<04176>>17470000
      A specific entry will not affect the "load" if it        <<04176>>17475000
      pertains to a file which is opened,active or deferred.   <<04176>>17480000
   ;                                                           <<04176>>17485000
   IF XDDS'SPOOL'STATE <> XDDS'OPEN  AND                       <<06744>>17490000
      XDDS'SPOOL'STATE <> XDDS'ACTIVE AND                      <<06744>>17495000
      (XDDS'OUTPUT'PRIORITY > XDD0'SYSTEM'OUTFENCE OR          <<07438>>17500000
          (XDDH'DEV'OUTFENCE <> 0 LAND                         <<07438>>17505000
           XDDS'OUTPUT'PRIORITY > XDDH'DEV'OUTFENCE)) THEN     <<07438>>17510000
      DEMAND := ODDS'NUMBER'COPIES;                            <<06744>>17515000
   END;    <<DEMAND>>                                                   17520000
                                                                        17525000
$PAGE "Procedure SHOWFILES - subroutine NEXTENTRY"             <<07438>>17530000
LOGICAL SUBROUTINE NEXTENTRY;                                  <<07438>>17535000
                                                               <<07438>>17540000
BEGIN                                                          <<07438>>17545000
  COMMENT -- This subroutine is  responsible  for  moving  the <<07438>>17550000
next subentry to be tested into XDD'SUBENTRY.  This is usually <<07438>>17555000
as straightforward as taking the next subentry  on  the  chain <<07438>>17560000
defined by the current head entry.  However, when the user has <<07438>>17565000
specified all entries and we are on the class chain,  we  must <<07438>>17570000
gather  all  the subentries from a specific device class while <<07438>>17575000
making sure we visit each subentry only once. Since subentries <<07438>>17580000
are not so linked on the class chain, we use  a  local  array, <<07438>>17585000
XDD'CLASS'INDICES,  which  is  built before this subroutine is <<07438>>17590000
first called.  This contains NUM'XDD'CLASSES entries, one  for <<07438>>17595000
each Device Class Table index represented in the XDD.  We only <<07438>>17600000
accept subentries from the current class index.  If  we  reach <<07438>>17605000
the  end of the class chain, we start over with the next class <<07438>>17610000
in XDD'CLASS'INDICES unless that too is exhausted.             <<07438>>17615000
  If a testable subentry is found, it is returned in  XDD'SUB- <<07438>>17620000
ENTRY  and NEXTENTRY is returned TRUE.  If the end of the cur- <<07438>>17625000
rent chain (taking the discussion above into account) is found <<07438>>17630000
XDD'SUBENTRY returns FALSE.                                    <<07438>>17635000
   NEXTENTRY maintains RANK as it proceeds down a  chain,  and <<07438>>17640000
resets  it  to  0  if  starting down the class chain for a new <<07438>>17645000
class.                                                         <<07438>>17650000
  XDD'HEAD, XDD'SUBENTRY, XDD'CLASS'INDICES and CURRENT'CLASS' <<07438>>17655000
INDEX must all be properly initialized for NEXTENTRY to  work. <<07438>>17660000
NEXTENTRY  updates XDD'SUBENTRY and CURRENT'CLASS'INDEX as re- <<07438>>17665000
quired.                                                        <<07438>>17670000
;                                                              <<07438>>17675000
IF DEV = NODEV  AND  XDDH'LDEV = 0 THEN                        <<07438>>17680000
   BEGIN   << Scanning all devices and on class chain.      >> <<07438>>17685000
   IF OUT THEN RANK := RANK + DEMAND (XDD'SUBENTRY);           <<07438>>17690000
                                                               <<07438>>17695000
LOOP:                                                          <<07438>>17700000
                                                               <<07438>>17705000
   FOUND'ONE := FALSE;                                         <<07438>>17710000
   WHILE XDDS'NEXT'SUBENTRY <> XDDS'END'OF'CHAIN               <<07438>>17715000
         AND NOT FOUND'ONE DO                                  <<07438>>17720000
      BEGIN   << Get next subentry for this class.          >> <<07438>>17725000
      MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST, XDDS'NEXT'SUBENTRY, <<07438>>17730000
                    XDD0'SUBENTRY'LENGTH);                     <<07438>>17735000
      IF XDDS'DEVICE = XDD'CLASS'INDICES(CURRENT'CLASS'INDEX)  <<07438>>17740000
         THEN FOUND'ONE := TRUE                                <<07438>>17745000
      END;    << Get next subentry for this class.          >> <<07438>>17750000
   IF NOT FOUND'ONE THEN                                       <<07438>>17755000
      BEGIN   << No more subentries in current device class >> <<07438>>17760000
      IF (CURRENT'CLASS'INDEX := CURRENT'CLASS'INDEX+1) <      <<07438>>17765000
         NUM'XDD'CLASSES THEN                                  <<07438>>17770000
         BEGIN   << At least one more class to try.         >> <<07438>>17775000
         XDDS'NEXT'SUBENTRY := XDDH'FIRST'SUBENTRY;            <<07438>>17780000
         RANK := 0;                                            <<07438>>17785000
         GO LOOP;                                              <<07438>>17790000
         END;    << At least one more class to try.         >> <<07438>>17795000
      END;    << No more subentries in current device class >> <<07438>>17800000
   END     << Scanning all devices and on class chain.      >> <<07438>>17805000
ELSE                                                           <<07438>>17810000
   BEGIN   << Scanning one dev/class, or not on class chain >> <<07438>>17815000
   IF OUT THEN                                                 <<07438>>17820000
      BEGIN                                                    <<07438>>17825000
                                                               <<07438>>17830000
  COMMENT -- Compute RANK as required.  "Required" here means: <<07438>>17835000
1.  DEV > 0, we are scanning a particular device chain and  no <<07438>>17840000
             others will be presented to us.                   <<07438>>17845000
2.  DEV < 0, we are scanning the device class chain for a par- <<07438>>17850000
             ticular class, or a chain for a  device  in  that <<07438>>17855000
             class.                                            <<07438>>17860000
3.  DEV = 0, we are scanning a device chain as part  of  scan- <<07438>>17865000
             ning  them  all.  Note  that  we are never on the <<07438>>17870000
             class chain since that was handled above.         <<07438>>17875000
;                                                              <<07438>>17880000
      IF DEV > 0                           << Case 1.       >> <<07438>>17885000
         OR XDDH'LDEV <> 0                 << Case 2 or 3.  >> <<07438>>17890000
         OR XDDS'DEVICE = LOGICAL (-DEV)   << Case 2, class >> <<07438>>17895000
         THEN RANK := RANK + DEMAND (XDD'SUBENTRY);            <<07438>>17900000
      END;                                                     <<07438>>17905000
   FOUND'ONE := XDDS'NEXT'SUBENTRY <> XDDS'END'OF'CHAIN;       <<07438>>17910000
   IF FOUND'ONE THEN MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST,      <<07438>>17915000
      XDDS'NEXT'SUBENTRY, XDD0'SUBENTRY'LENGTH);               <<07438>>17920000
   END;    << Scanning one dev/class, or not on class chain >> <<07438>>17925000
NEXTENTRY := FOUND'ONE;                                        <<07438>>17930000
END;    << of NEXTENTRY.                                    >> <<07438>>17935000
                                                                        17940000
$PAGE "Procedure SHOWFILES - subroutine NEXTHEAD"              <<07438>>17945000
LOGICAL SUBROUTINE NEXTHEAD;                                   <<07438>>17950000
                                                               <<07438>>17955000
BEGIN                                                          <<07438>>17960000
  COMMENT -- loads XDD'HEAD with next head entry to  be  used, <<07438>>17965000
as  determined  by DEV.  If no more head chains are to be pro- <<07438>>17970000
cessed, NEXTHEAD returns FALSE, else it returns TRUE.          <<07438>>17975000
;                                                              <<07438>>17980000
NEXTHEAD := FALSE;                                             <<07438>>17985000
IF DEV > 0 THEN                                                <<07438>>17990000
   RETURN   << Specific device, scan no other chains.       >> <<07438>>17995000
ELSE                                                           <<07438>>18000000
   IF DEV = NODEV THEN                                         <<07438>>18005000
      BEGIN   << All devices, fetch the next chain.         >> <<07438>>18010000
      IF (HEAD'ENTRY'OFFSET := HEAD'ENTRY'OFFSET +             <<07438>>18015000
         XDD0'HEAD'LENGTH) <= LOGICAL (@LASTHEADP) THEN        <<07438>>18020000
         BEGIN   << Next chain exists.                      >> <<07438>>18025000
         MOVEFROMDSEG (XDD'HEAD, XDD'DST,                      <<07438>>18030000
             HEAD'ENTRY'OFFSET, XDD0'HEAD'LENGTH);             <<07438>>18035000
         NEXTHEAD := TRUE;                                     <<07438>>18040000
         END;    << Next chain exists.                      >> <<07438>>18045000
      END                                                      <<07438>>18050000
   ELSE                                                        <<07438>>18055000
      BEGIN   << Class, return chain of next dev in class.  >> <<07438>>18060000
      IF (CURRENT'DEV'INDEX := CURRENT'DEV'INDEX + 1) <        <<07438>>18065000
         NUMDEVS THEN                                          <<07438>>18070000
         BEGIN                                                 <<07438>>18075000
         MOVEFROMDSEG (XDD'HEAD, XDD'DST,                      <<07438>>18080000
            CLASS'XDD'HEADS(CURRENT'DEV'INDEX) *               <<07438>>18085000
            XDD0'HEAD'LENGTH, XDD0'HEAD'LENGTH);               <<07438>>18090000
         NEXTHEAD := TRUE;                                     <<07438>>18095000
         END;                                                  <<07438>>18100000
      END;    << Class, return chain of next dev in class.  >> <<07438>>18105000
END;    << of NEXTHEAD.                                     >> <<07438>>18110000
$PAGE "Procedure SHOWFILES - subroutine PUTENTRY"              <<07438>>18115000
LOGICAL SUBROUTINE PUTENTRY (DSTNUM,SOURCE,COUNT);             <<00548>>18120000
   VALUE DSTNUM,SOURCE,COUNT;                                  <<00548>>18125000
   LOGICAL DSTNUM,COUNT;                                       <<00548>>18130000
   LOGICAL POINTER SOURCE;                                     <<00548>>18135000
                                                               <<00548>>18140000
BEGIN                                                          <<00548>>18145000
   COMMENT:                                                    <<00548>>18150000
      MOVE 'COUNT' WORDS FROM 'SOURCE' TO THE NEXT             <<00548>>18155000
      LOCATION IN DST 'DSTNUM'.;                               <<00548>>18160000
   IF (ENDOFDATA+COUNT) <= DSTLENGTH THEN                      <<00548>>18165000
      BEGIN                                                    <<00548>>18170000
      PUTENTRY := TRUE;                                        <<00548>>18175000
      MOVETODSEG (DSTNUM,ENDOFDATA,SOURCE,COUNT);              <<00548>>18180000
      ENDOFDATA := ENDOFDATA +COUNT;                           <<00548>>18185000
      END                                                      <<00548>>18190000
   ELSE                                                        <<00548>>18195000
      BEGIN << OUT OF SPACE >>                                 <<00548>>18200000
      ERRNUM := SHOWSYSERR;                                    <<00548>>18205000
      PUTENTRY := FALSE;                                       <<00548>>18210000
      END;                                                     <<00548>>18215000
END;    <<PUTENTRY>>                                           <<00548>>18220000
$PAGE "Procedure SHOWFILES - subroutine GETENTRY"              <<07438>>18225000
LOGICAL SUBROUTINE GETENTRY (TARGET,DSTNUM,COUNT);             <<00548>>18230000
   VALUE TARGET,DSTNUM,COUNT;                                  <<00548>>18235000
   LOGICAL DSTNUM,COUNT;                                       <<00548>>18240000
   LOGICAL POINTER TARGET;                                     <<00548>>18245000
BEGIN                                                          <<00548>>18250000
   COMMENT:                                                    <<00548>>18255000
      MOVE THE NEXT 'COUNT' WORDS FROM DST 'DSTNUM'            <<00548>>18260000
      INTO 'SOURCE'.;                                          <<00548>>18265000
   IF NEXTLOC >= ENDOFDATA THEN GETENTRY := FALSE              <<00548>>18270000
   ELSE                                                        <<00548>>18275000
      BEGIN                                                    <<00548>>18280000
      GETENTRY := TRUE;                                        <<00548>>18285000
      MOVEFROMDSEG (TARGET,DSTNUM,NEXTLOC,COUNT);              <<00548>>18290000
      NEXTLOC := NEXTLOC + COUNT;                              <<00548>>18295000
      END;                                                     <<00548>>18300000
END;    <<GETENTRY>>                                           <<00548>>18305000
$PAGE "Procedure SHOWFILES - subroutine INCRCOUNTS"            <<07438>>18310000
                                                                        18315000
SUBROUTINE INCRCOUNTS;                                                  18320000
<< UPDATES COUNTS FOR FINAL/"STATUS" REPORT >>                          18325000
BEGIN                                                                   18330000
   ST := XDDS'SPOOL'STATE;                                     <<06744>>18335000
   << UPDATE STATE COUNT >>                                             18340000
   STCOUNTS (ST) := STCOUNTS (ST) +1;                                   18345000
   IF  OUT  AND  XDDS'OUTPUT'PRIORITY <= XDD0'SYSTEM'OUTFENCE  <<07438>>18350000
            AND  (XDDH'DEV'OUTFENCE = 0                        <<07438>>18355000
                 OR XDDS'OUTPUT'PRIORITY <= XDDH'DEV'OUTFENCE) <<07438>>18360000
      THEN                                                     <<06744>>18365000
      << UPDATE DEFERRED COUNT >>                                       18370000
      DEFCOUNTS (ST) := DEFCOUNTS (ST) +1;                              18375000
 IF XDDS'SPOOFLE'VT'INDEX <> 0 THEN                            <<06916>>18380000
    BEGIN    <<UPDATE SPOOFLE COUNTS>>                                  18385000
    SPCOUNTS (ST) := SPCOUNTS (ST) +1;                                  18390000
    TOS := XDDS'NUMBER'EXTENTS;                                <<06744>>18395000
    IF = THEN TOS := TOS+2;                                             18400000
    TOS := LOGICAL(TOS-1) ** ABSYS'EXTSSECT;                            18405000
    TOS := TOS+DOUBLE(XDDS'LAST'EXTENT'SIZE);                  <<06744>>18410000
    SPSPACE := TOS +SPSPACE;                                            18415000
    END;                                                                18420000
   END;    <<INCRCOUNTS>>                                               18425000
                                                                        18430000
$PAGE "Procedure SHOWFILES - subroutine VISITENTRY"            <<07438>>18435000
SUBROUTINE VISITENTRY;                                                  18440000
<< WRITES <ENTRYP> OUT TO TEMPORARY FILE.  REPLACES LINK WITH           18445000
   ENTRY'S RANK (FROM <RANK>) FOR OUTPUT SUBENTRIES. >>                 18450000
BEGIN                                                                   18455000
   SAVELINK := OD'RANK;                                        <<06744>>18460000
   IF OUT THEN                                                          18465000
      BEGIN                                                             18470000
      IF DEMAND (XDD'SUBENTRY) > 0 THEN TOS := RANK +1         <<06744>>18475000
      ELSE TOS := 0;                                                    18480000
      XDDS'NEXT'SUBENTRY := TOS;                               <<06744>>18485000
      END;                                                              18490000
   IF NOT PUTENTRY (DSTNUM,XDD'SUBENTRY,                       <<06744>>18495000
      SIZE'OF'XDD'SUBENTRY) THEN                               <<06744>>18500000
      STOP := TRUE;                                            <<00548>>18505000
   INCRCOUNTS;                                                 <<00548>>18510000
   OD'RANK := SAVELINK;                                        <<06744>>18515000
   END;    <<VISITENTRY>>                                               18520000
                                                                        18525000
$PAGE "Procedure SHOWFILES - subroutine WRITE"                 <<07438>>18530000
SUBROUTINE WRITE (LEN, CONTROL);                                        18535000
   VALUE LEN, CONTROL;                                                  18540000
   INTEGER LEN, CONTROL;                                                18545000
<< PRINTS (OBUF, <LEN>, <CONTROL>); TAKING INTO ACCOUNT BREAK           18550000
   REQUEST AND ERROR (IN WHICH CASES IT GOES TO LEAVE).  >>             18555000
BEGIN                                                                   18560000
   IF REQUESTSERVICE THEN GOTO LEAVE;                                   18565000
   PRINT (OBUF, LEN, CONTROL);                                          18570000
   IF <> THEN GOTO LEAVE;                                               18575000
   END;    <<WRITE>>                                                    18580000
$PAGE "Procedure SHOWFILES - subroutine ALLOCATEDST"           <<07438>>18585000
LOGICAL SUBROUTINE ALLOCATEDST (DSTNUM,DSTSIZE);               <<00548>>18590000
                                                               <<S8106>>18595000
   VALUE   DSTSIZE;                                            <<S8106>>18600000
   INTEGER DSTNUM, DSTSIZE;                                    <<00548>>18605000
BEGIN COMMENT --                                               <<S8106>>18610000
  We use the callable GETDSEG so that the segment  we  acquire <<S8106>>18615000
will  be  released automatically if our process terminates ab- <<S8106>>18620000
normally.  DSTSIZE < 0 causes GETDSEG to ignore the configured <<S8106>>18625000
user DST size limit iff the caller is privileged.              <<S8106>>18630000
  Returns:  ALLOCATEDST TRUE, segment allocated and its number <<S8106>>18635000
              returned in DSTNUM.                              <<S8106>>18640000
            ALLOCATEDST FALSE, could not allocate segment, and <<S8106>>18645000
              the reason why is in ERRNUM.                     <<S8106>>18650000
;                                                              <<S8106>>18655000
   ALLOCATEDST := TRUE;                                        <<00548>>18660000
   DSTSIZE := -DSTSIZE;   << Reference parm to GETDSEG.     >> <<S8106>>18665000
   GETDSEG (DSTNUM,DSTSIZE,0);                                 <<00548>>18670000
   IF <> THEN                                                  <<00548>>18675000
      BEGIN                                                    <<00548>>18680000
      ERRNUM := IF > OR DSTNUM=%2000 THEN SHOWSYSERR           <<00548>>18685000
                ELSE IF DSTNUM=%2001 THEN SHOWNODST            <<00548>>18690000
                ELSE SHOWNOVDS;                                <<00548>>18695000
      ALLOCATEDST:=DSTNUM:=0;                                  <<00548>>18700000
      END;                                                     <<00548>>18705000
END;    <<ALLOCATEDST>>                                        <<00548>>18710000
$PAGE "Procedure SHOWFILES - procedure body"                   <<07438>>18715000
<< PARSE COMMAND >>                                                     18720000
                                                                        18725000
SHOWFILES := 0;  <<NO ERROR NUMBER SO FAR>>                    <<U.RAO>>18730000
JOBNUM := INJOBNUM;  <<INIT FOR INDIVIDUAL USERS>>             <<U.RAO>>18735000
IF INJOBNUM=0 THEN   <<CONSOLE COMMAND>>                       <<U.RAO>>18740000
   ALLFLAG := TRUE;  <<INITIALIZE TO ALL FILES>>               <<U.RAO>>18745000
MOVE KEYWORDSW := KEYWORDSPW, (KEYLEN);                        <<U.RAO>>18750000
MYCOMMAND(PARMSTRING,,MAXPARMS,NUMPARMS,PARMS(1));             <<U.RAO>>18755000
IF NUMPARMS>0 THEN   <<SOMETHING THERE, PARSE IT>>             <<U.RAO>>18760000
   BEGIN                                                       <<U.RAO>>18765000
   PARM := PARMS(PNUM:=1);  <<GET FIRST PARM>>                 <<U.RAO>>18770000
   IF PP="#" THEN  <<PROBABLY A PARTICULAR DEVICEFILE>>        <<U.RAO>>18775000
      BEGIN                                                    <<U.RAO>>18780000
      ALLFLAG := TRUE;  <<INITIALIZE IN CASE OF ERROR>>        <<U.RAO>>18785000
      IF (PP(1) <> "I") AND NOT OUT THEN                       <<01651>>18790000
         ERROR(SHOWFXPCTIDEVFL)                                <<U.RAO>>18795000
      ELSE IF (PP(1) <> "O") AND OUT THEN                      <<01651>>18800000
         ERROR(SHOWFXPCTODEVFL)                                <<U.RAO>>18805000
      ELSE  <<APPROPRIATE REQUEST>>                            <<U.RAO>>18810000
         BEGIN  <<CHECK FOR ID NUMBER>>                        <<U.RAO>>18815000
         ALLFLAG := FALSE;                                     <<U.RAO>>18820000
         DFID := BINARY(PP(2), PLEN-2);                        <<U.RAO>>18825000
         IF <> OR DFID<0 THEN                                  <<U.RAO>>18830000
            BEGIN                                              <<U.RAO>>18835000
            ERROR(SHOWFINVLDDFID);                             <<U.RAO>>18840000
            DFID := 0;  <<REINITIALIZE>>                       <<U.RAO>>18845000
            END                                                <<U.RAO>>18850000
         END;                                                  <<U.RAO>>18855000
      IF NUMPARMS>1 THEN                                       <<U.RAO>>18860000
         BEGIN  <<TOO MANY PARMS>>                             <<U.RAO>>18865000
         PARM := PARMS(PNUM:=2);                               <<U.RAO>>18870000
         ERROR(SHOWFXTRAIGNORD);                               <<U.RAO>>18875000
         END;                                                  <<U.RAO>>18880000
      END                                                      <<U.RAO>>18885000
   ELSE  <<REGULAR PARMS, TO BE REGULARLY PARSED>>             <<U.RAO>>18890000
      BEGIN                                                    <<U.RAO>>18895000
      PNUM := 0;                                               <<U.RAO>>18900000
      PARMNUM := 0;                                            <<U.RAO>>18905000
      DO BEGIN  <<UNTIL NO MORE KEYWORDS>>                     <<U.RAO>>18910000
         GETNEXT;                                              <<U.RAO>>18915000
         IF PLEN <> 0 THEN   <<NOT AN EXTRANEOUS DELIMITER>>   <<U.RAO>>18920000
            BEGIN                                              <<U.RAO>>18925000
            IF SEARCH(PP,PLEN,KEYWORDS,KEYDEFN)=0 THEN         <<U.RAO>>18930000
               ERROR(SHOWFUNKKEY)                              <<U.RAO>>18935000
            ELSE  <<VALID KEYWORD>>                            <<U.RAO>>18940000
               CASE *INTEGER(KEYDEFN) OF                       <<U.RAO>>18945000
               BEGIN   <<LOOK AT INDIVIDUAL PARAMETERS>>       <<U.RAO>>18950000
                                                               <<U.RAO>>18955000
                  ;  <<CAN'T HAPPEN>>                          <<U.RAO>>18960000
                                                               <<U.RAO>>18965000
                  PARSEDEV;    <<DEV PARAMETER>>               <<U.RAO>>18970000
                                                               <<U.RAO>>18975000
                  PARSEJOB;    <<JOB PARAMETER>>               <<U.RAO>>18980000
                                                               <<U.RAO>>18985000
                  PARSESTATE;  <<READY, ACTIVE, OPENED, LOCKED><<U.RAO>>18990000
                                                               <<U.RAO>>18995000
                  BEGIN        <<STATUS PARAMETER>>            <<U.RAO>>19000000
                  IF NUMPARMS <> 1 THEN  <<OTHER PARMS INAPPROP<<U.RAO>>19005000
                     ERROR(SHOWFSTATSIGNRD)                    <<U.RAO>>19010000
                  ELSE                                         <<U.RAO>>19015000
                     STATUS := TRUE;                           <<U.RAO>>19020000
                  END;                                         <<U.RAO>>19025000
                                                               <<U.RAO>>19030000
                  SP := TRUE;  <<ALL SPOOLED FILES, SP>>       <<U.RAO>>19035000
                                                               <<U.RAO>>19040000
               END;                                            <<U.RAO>>19045000
            END                                                <<U.RAO>>19050000
         END                                                   <<U.RAO>>19055000
      UNTIL (PDEL<>SEMI) OR STOP;                              <<U.RAO>>19060000
      IF (PDEL<>CR) AND NOT STOP THEN  <<UNKNOWN JUNK IN STRING<<U.RAO>>19065000
         BEGIN                                                 <<U.RAO>>19070000
         PARM := PARMS(PNUM:=PNUM+1);                          <<U.RAO>>19075000
         ERROR(SHOWFXTRANPARMS);                               <<U.RAO>>19080000
         END;                                                  <<U.RAO>>19085000
      END;                                                     <<U.RAO>>19090000
   PARMNUM := PNUM := 0;  <<SUCCESSFUL PARSE>>                 <<U.RAO>>19095000
   STOP := FALSE;                                              <<U.RAO>>19100000
   END;   <<PARSER>>                                           <<U.RAO>>19105000
                                                                        19110000
   STCOUNTS := 0;                                                       19115000
   MOVE STCOUNTS (1) := STCOUNTS, (3);                         <<06744>>19120000
   MOVE DEFCOUNTS := STCOUNTS, (4);                                     19125000
   MOVE SPCOUNTS := STCOUNTS, (4);                                      19130000
   IF OUT THEN                                                 <<06744>>19135000
      BEGIN                                                    <<06744>>19140000
      DFID.(0:1) := 1;                                         <<06744>>19145000
      XDDSIR := ODD'SIR;                                       <<06744>>19150000
      XDD'DST := ODD'DST;                                      <<06744>>19155000
      END                                                      <<06744>>19160000
   ELSE                                                        <<06744>>19165000
      BEGIN                                                    <<06744>>19170000
      XDDSIR := IDD'SIR;                                       <<06744>>19175000
      XDD'DST := IDD'DST;                                      <<06744>>19180000
      END;                                                     <<06744>>19185000
   SAVESIR := GETSIR (XDDSIR);                                 <<07438>>19190000
   MOVEFROMDSEG (XDD, XDD'DST, 0, SIZE'OF'XDD0);               <<07438>>19195000
   DSTLENGTH := XDD0'CURRENT'SECTORS*SECTOR'SIZE;              <<06744>>19200000
   IF NOT ALLOCATEDST(DSTNUM,DSTLENGTH) THEN                   <<06744>>19205000
      BEGIN                                                    <<06744>>19210000
      RELSIR(XDDSIR,SAVESIR);                                  <<06744>>19215000
      FATALERROR;                                              <<06744>>19220000
      END                                                      <<06744>>19225000
   ELSE                                                        <<06744>>19230000
      ENDOFDATA := 0;                                          <<06744>>19235000
   IF DFID.(1:15) <> 0 THEN                                             19240000
      BEGIN    <<DEVICEFILEID SEARCH>>                                  19245000
      IF OUT THEN                                              <<07438>>19250000
         FOUND'ONE :=  SFINDODD (DFID, SUBENTRY'OFFSET)        <<07438>>19255000
      ELSE                                                     <<07438>>19260000
         FOUND'ONE :=  SFINDIDD (DFID, SUBENTRY'OFFSET);       <<07438>>19265000
      IF FOUND'ONE THEN                                        <<07438>>19270000
         BEGIN   << Found a subentry.                       >> <<07438>>19275000
         MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST,                  <<07438>>19280000
            SUBENTRY'OFFSET.(1:15), XDD0'SUBENTRY'LENGTH);     <<07438>>19285000
         MOVEFROMDSEG (XDD'HEAD, XDD'DST, XDDS'HEAD'INDEX *    <<07438>>19290000
                       XDD0'HEAD'LENGTH, XDD0'HEAD'LENGTH);    <<07438>>19295000
         IF OUT  AND  DEMAND (XDD'SUBENTRY) > 0 THEN           <<07438>>19300000
            BEGIN   << Ranked file, calculate rank.         >> <<07438>>19305000
                                                               <<07438>>19310000
  COMMENT -- Ranking in SHOWFILES (also throughout  HP)  is  a <<07438>>19315000
confusing  concept and requires a bit of explanation.  Rank is <<07438>>19320000
the position of a file in the output priority list of a device <<07438>>19325000
or device class, taking into account the number of  copies  of <<07438>>19330000
all previous files in the list.  Thus if there are three files <<07438>>19335000
in the list, each requiring two copies, before the DFID of in- <<07438>>19340000
terest, that DFID will have a rank of 7.  It should  be  noted <<07438>>19345000
that  a  rank of 7 does not mean that this will be the seventh <<07438>>19350000
file printed, because spoolers choose their next files using a <<07438>>19355000
somewhat modified algorithm. Thus rank should be taken only as <<07438>>19360000
a general indicator of position (again, cf. HP!). Rank is cal- <<07438>>19365000
culated only for ready or locked output files  whose  priority <<07438>>19370000
is  above  the  system  outfence (or the device outfence for a <<07438>>19375000
file on a device list with a device-specific outfence).  These <<07438>>19380000
lists are kept in the XDD, linked by file priority.  Thus  the <<07438>>19385000
code below scans the appropriate list by following the links.  <<07438>>19390000
;                                                              <<07438>>19395000
            XDD'LDEV := XDDS'DEVICE;                           <<07438>>19400000
            SUBENTRY'OFFSET := XDDH'FIRST'SUBENTRY;            <<07438>>19405000
            FOUND'ONE := FALSE;  << Guards against bad XDD. >> <<07438>>19410000
            WHILE SUBENTRY'OFFSET <> XDDS'END'OF'CHAIN         <<07438>>19415000
                  AND NOT FOUND'ONE DO                         <<07438>>19420000
               BEGIN   << Scan down chain to match DFID.    >> <<07438>>19425000
               MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST,            <<07438>>19430000
                   SUBENTRY'OFFSET, XDD0'SUBENTRY'LENGTH);     <<07438>>19435000
               IF XDDS'DFID'NUMBER = LOGICAL (DFID.(1:15)) THEN<<07438>>19440000
                  FOUND'ONE := TRUE                            <<07438>>19445000
               ELSE                                            <<07438>>19450000
                  BEGIN   << Haven't found it yet.          >> <<07438>>19455000
                  IF XDDS'DEVICE = XDD'LDEV THEN               <<07438>>19460000
                     RANK := RANK + DEMAND (XDD'SUBENTRY);     <<07438>>19465000
                  SUBENTRY'OFFSET := XDDS'NEXT'SUBENTRY;       <<07438>>19470000
                  END;    << Haven't found it yet.          >> <<07438>>19475000
               END;    << Scan down chain to match DFID.    >> <<07438>>19480000
            END;    << Ranked file, calculate rank.         >> <<07438>>19485000
         IF FOUND'ONE THEN VISITENTRY;                         <<07438>>19490000
         END;    << Found a subentry.                       >> <<07438>>19495000
      END     << DFID search.                               >> <<07438>>19500000
   ELSE                                                                 19505000
      BEGIN    <<VISIT EVERY ENTRY SATISFYING <DEV>, <JOB>, <STATE>>    19510000
                                                               <<07438>>19515000
      << SET UP FOR SCAN OF ENTRIES IN SET OF CHAINS >>                 19520000
                                                               <<07438>>19525000
      HEAD'ENTRY'OFFSET := XDD'CLASS'ENTRY;                    <<07438>>19530000
      MOVEFROMDSEG (XDD'HEAD, XDD'DST, HEAD'ENTRY'OFFSET,      <<07438>>19535000
                    XDD0'HEAD'LENGTH);                         <<07438>>19540000
      IF DEV = 0 THEN                                                   19545000
         BEGIN    <<SCAN ALL DEV CHAINS>>                               19550000
         IF OUT THEN                                           <<07438>>19555000
            BEGIN   << Scan device class chain as well.     >> <<07438>>19560000
                                                               <<07438>>19565000
  COMMENT -- In our final display we want to group all entries <<07438>>19570000
in a given class.  Since there is only one device class  chain <<07438>>19575000
in  the  ODD for all device classes on the system, and the en- <<07438>>19580000
tries on it are not so grouped, we need local help.  We  build <<07438>>19585000
an  array  of device class indices (taken from the ODD) on the <<07438>>19590000
stack, one entry for each unique device class index.  Later on <<07438>>19595000
we'll use this array to scan the device class chain  repeated- <<07438>>19600000
ly,  taking only the entries corresponding to the device class <<07438>>19605000
of current interest.                                           <<07438>>19610000
;                                                              <<07438>>19615000
            PUSH (S);                                          <<07438>>19620000
            @XDD'CLASS'INDICES := TOS + 1;                     <<07438>>19625000
            NUM'XDD'CLASSES := 0;                              <<07438>>19630000
            SUBENTRY'OFFSET := XDDH'FIRST'SUBENTRY;            <<07438>>19635000
            WHILE SUBENTRY'OFFSET <> XDDS'END'OF'CHAIN DO      <<07438>>19640000
               BEGIN   << Scan class chain for unique class >> <<07438>>19645000
               MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST,            <<07438>>19650000
                  SUBENTRY'OFFSET, XDD0'SUBENTRY'LENGTH);      <<07438>>19655000
               CURRENT'CLASS'INDEX := 0;                       <<07438>>19660000
               FOUND'ONE := FALSE;                             <<07438>>19665000
               WHILE CURRENT'CLASS'INDEX < NUM'XDD'CLASSES     <<07438>>19670000
                  AND NOT FOUND'ONE DO                         <<07438>>19675000
                  IF XDDS'DEVICE =                             <<07438>>19680000
                     XDD'CLASS'INDICES(CURRENT'CLASS'INDEX)    <<07438>>19685000
                     THEN FOUND'ONE := TRUE                    <<07438>>19690000
                  ELSE CURRENT'CLASS'INDEX :=                  <<07438>>19695000
                       CURRENT'CLASS'INDEX + 1;                <<07438>>19700000
               IF NOT FOUND'ONE THEN                           <<07438>>19705000
                  BEGIN   << New class, add it to TOS array >> <<07438>>19710000
                  TOS := XDDS'DEVICE;                          <<07438>>19715000
                  NUM'XDD'CLASSES := NUM'XDD'CLASSES + 1;      <<07438>>19720000
                  END;    << New class, add it to TOS array >> <<07438>>19725000
               SUBENTRY'OFFSET := XDDS'NEXT'SUBENTRY;          <<07438>>19730000
               END;    << Scan class chain for unique class >> <<07438>>19735000
            CURRENT'CLASS'INDEX := 0;   << Leave at start.  >> <<07438>>19740000
            END     << Scan device class chain as well.     >> <<07438>>19745000
         ELSE                                                  <<07438>>19750000
            BEGIN   << SHOWIN, no class chain.              >> <<07438>>19755000
            HEAD'ENTRY'OFFSET := HEAD'ENTRY'OFFSET +           <<07438>>19760000
                                 XDD0'HEAD'LENGTH;             <<07438>>19765000
            MOVEFROMDSEG (XDD'HEAD, XDD'DST, HEAD'ENTRY'OFFSET,<<07438>>19770000
                          XDD0'HEAD'LENGTH);                   <<07438>>19775000
            END;    << SHOWIN, no class chain.              >> <<07438>>19780000
         END     << Scan all device chains.                 >> <<07438>>19785000
      ELSE                                                              19790000
         << Specific device or class.                       >> <<07438>>19795000
         IF DEV > 0 THEN                                                19800000
            BEGIN  << Specific dev, get head index from LDT >> <<07438>>19805000
            HEAD'ENTRY'OFFSET := G'XDD'HEAD'INDEX *            <<07438>>19810000
                                 INTEGER (XDD0'HEAD'LENGTH);   <<07438>>19815000
            MOVEFROMDSEG (XDD'HEAD, XDD'DST, HEAD'ENTRY'OFFSET,<<07438>>19820000
                          XDD0'HEAD'LENGTH);                   <<07438>>19825000
                                                               <<07438>>19830000
<< The following test corrects a bug  that  used  to  allow >> <<07438>>19835000
<< users  to :SHOWIN an output-only LDEV or :SHOWOUT an in- >> <<07438>>19840000
<< put-only LDEV.  The LDT contains an XDD head index,  but >> <<07438>>19845000
<< doesn't specify whether XDD = IDD or ODD.  For DEV to be >> <<07438>>19850000
<< valid, its LDT's XDD index must be within the head entry >> <<07438>>19855000
<< area of the XDD -AND- the LDEV in the  head  entry  must >> <<07438>>19860000
<< match DEV.  If either test fails, we report an error.    >> <<07438>>19865000
                                                               <<07438>>19870000
            IF G'XDD'HEAD'INDEX < XDD'CLASS'INDEX + 1          <<07438>>19875000
               OR HEAD'ENTRY'OFFSET + XDD0'HEAD'LENGTH >       <<07438>>19880000
                  XDD0'SUBENTRY'AREA                           <<07438>>19885000
               OR XDDH'LDEV <> LOGICAL (DEV) THEN              <<07438>>19890000
               BEGIN   << LDEV not in XDD.                  >> <<07438>>19895000
               RELSIR (XDDSIR, SAVESIR);                       <<B7518>>19900000
               IF OUT THEN                                     <<07438>>19905000
                  ERRNUM := LDEVNOTINODD                       <<07438>>19910000
               ELSE                                            <<07438>>19915000
                  ERRNUM := LDEVNOTINIDD;                      <<07438>>19920000
               FATALERROR;                                     <<07438>>19925000
               END;    << LDEV not in XDD.                  >> <<07438>>19930000
            END    << Specific dev, get head index from LDT >> <<07438>>19935000
         ELSE                                                           19940000
            BEGIN   << Device class.                        >> <<07438>>19945000
                                                               <<07438>>19950000
  COMMENT -- A device class can have several devices.  We need <<07438>>19955000
to scan down each XDD device subentry chain in the  class.  To <<07438>>19960000
do  this,  first fetch the list of LDEVs in the class from the <<07438>>19965000
Device Class Table entry  (built  on  the  stack  because  its <<07438>>19970000
length  is unknown at entry to SHOWFILES), then form a similar <<07438>>19975000
list of XDD head indices (also on the stack) from the LDT  en- <<07438>>19980000
try  for  each LDEV in the class.  Use these to scan the links <<07438>>19985000
for all files on each LDEV.                                    <<07438>>19990000
;                                                              <<07438>>19995000
            CLASS'LENGTH := GET'DEVICE'CLASS (-DEV,            <<07438>>20000000
                            CLASS'ADDRESS);                    <<07438>>20005000
            PUSH (S);                                          <<07438>>20010000
            @DCT := TOS + 1;                                   <<07438>>20015000
            TOS := CLASS'LENGTH;                               <<07438>>20020000
            ASSEMBLE (ADDS 0);                                 <<07438>>20025000
            MOVEFROMDSEG (DCT, DCT'DST, CLASS'ADDRESS,         <<07438>>20030000
                          CLASS'LENGTH);                       <<07438>>20035000
            NUMDEVS := DCT'NUM'DEVICES;                        <<07438>>20040000
            PUSH (S);                                          <<07438>>20045000
            @CLASS'XDD'HEADS := TOS + 1;                       <<07438>>20050000
            TOS := NUMDEVS;                                    <<07438>>20055000
            ASSEMBLE (ADDS 0);                                 <<07438>>20060000
            CURRENT'DEV'INDEX := NUMDEVS;                      <<07438>>20065000
            WHILE (CURRENT'DEV'INDEX := CURRENT'DEV'INDEX - 1) <<07438>>20070000
                  >= 0 DO                                      <<07438>>20075000
               BEGIN   << Get XDD index for each LDEV.      >> <<07438>>20080000
               MOVEFROMDSEG (LDT, LDT'DST,                     <<07438>>20085000
                   DCT(DCT'FIRST'LDEV + CURRENT'DEV'INDEX) *   <<07438>>20090000
                   SIZE'OF'LDT'ENTRY, SIZE'OF'LDT'ENTRY);      <<07438>>20095000
               CLASS'XDD'HEADS(CURRENT'DEV'INDEX) :=           <<07438>>20100000
                  LDT'XDD'HEAD'INDEX;                          <<07438>>20105000
               END;    << Get XDD index for each LDEV.      >> <<07438>>20110000
            END;    << Device class.                        >> <<07438>>20115000
                                                               <<07438>>20120000
<< XDD'HEAD now contains proper entry for start of scan.    >> <<07438>>20125000
                                                               <<07438>>20130000
      @LASTHEADP := XDD0'SUBENTRY'AREA - XDD0'HEAD'LENGTH;     <<07438>>20135000
      IF STATUS THEN                                                    20140000
         BEGIN   << SHOWOUT/SHOWIN STATUS.                  >> <<07438>>20145000
         DO BEGIN   << This loop scans one head chain.      >> <<07438>>20150000
            SUBENTRY'OFFSET := XDDH'FIRST'SUBENTRY;            <<07438>>20155000
            WHILE SUBENTRY'OFFSET <> XDDS'END'OF'CHAIN DO      <<07438>>20160000
               BEGIN   << This loop scans one subentry.     >> <<07438>>20165000
               MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST,            <<07438>>20170000
                   SUBENTRY'OFFSET, XDD0'SUBENTRY'LENGTH);     <<07438>>20175000
               INCRCOUNTS;                                     <<07438>>20180000
               SUBENTRY'OFFSET := XDDS'NEXT'SUBENTRY;          <<07438>>20185000
               END;    << This loop scans one subentry.     >> <<07438>>20190000
            HEAD'ENTRY'OFFSET := HEAD'ENTRY'OFFSET +           <<07438>>20195000
               XDD0'HEAD'LENGTH;                               <<07438>>20200000
            IF INTEGER (HEAD'ENTRY'OFFSET) <= @LASTHEADP THEN  <<07438>>20205000
               MOVEFROMDSEG (XDD'HEAD, XDD'DST,                <<07438>>20210000
                  HEAD'ENTRY'OFFSET, XDD0'HEAD'LENGTH);        <<07438>>20215000
            END     << This loop scans one head chain.      >> <<07438>>20220000
         UNTIL INTEGER (HEAD'ENTRY'OFFSET) > @LASTHEADP;       <<07438>>20225000
         END     << SHOWOUT/SHOWIN STATUS.                  >> <<07438>>20230000
      ELSE                                                              20235000
         << DO QUALIFIED VISITING >>                                    20240000
         DO BEGIN   << This loop processes one head chain.  >> <<07438>>20245000
            HAVE'SUBENTRY := (XDDH'FIRST'SUBENTRY <>           <<07438>>20250000
                           XDDS'END'OF'CHAIN);                 <<07438>>20255000
            IF HAVE'SUBENTRY THEN                              <<07438>>20260000
               MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST,            <<07438>>20265000
                   XDDH'FIRST'SUBENTRY, XDD0'SUBENTRY'LENGTH); <<07438>>20270000
            WHILE HAVE'SUBENTRY  AND  NOT STOP DO              <<07438>>20275000
               BEGIN   << This loop processes one subentry. >> <<07438>>20280000
               IF  (DEV = 0)    << ALL >>                               20285000
               OR  (XDDH'LDEV <> 0)        << SPECIFIC DEV >>  <<06744>>20290000
               OR  (-DEV = INTEGER(XDDS'DEVICE)) THEN          <<06744>>20295000
                  << SATSIFIES CLASS >>                                 20300000
                  IF ALLFLAG    <<ALL FILES>>                  <<U.RAO>>20305000
                  OR (XDDS'JOB'NUMBER=0) << READY/INTRO :DATA>><<06744>>20310000
                  OR JOBNUM.(0:2) = INTEGER (XDDS'JOB'TYPE)    <<07438>>20315000
                     AND (JOBNUM.(2:14) = 0   << @ jobtype  >> <<07438>>20320000
                         OR JOBNUM.(2:14) =                    <<07438>>20325000
                            INTEGER (XDDS'JOB'NUMBER)) THEN    <<07438>>20330000
                     << SATISIFIES JOB >>                               20335000
                     IF  (STATE = NOSTATE)                              20340000
                     OR  (STATE = INTEGER(XDDS'SPOOL'STATE))   <<06744>>20345000
                        THEN                                   <<06744>>20350000
                        << SATISFIES STATE >>                           20355000
                        IF  (DEF = NODEF)                               20360000
                        OR  (DEF = DEFR)                                20365000
                              AND  XDDS'OUTPUT'PRIORITY <=     <<06744>>20370000
                                   XDD0'SYSTEM'OUTFENCE        <<06744>>20375000
                              AND (XDDH'DEV'OUTFENCE = 0       <<07438>>20380000
                                  OR XDDS'OUTPUT'PRIORITY <=   <<07438>>20385000
                                     XDDH'DEV'OUTFENCE)        <<07438>>20390000
                        OR  (DEF = NONDEFR)                             20395000
                              AND  (XDDS'OUTPUT'PRIORITY >     <<07438>>20400000
                                    XDD0'SYSTEM'OUTFENCE       <<06744>>20405000
                                OR (XDDH'DEV'OUTFENCE <> 0     <<07438>>20410000
                                   LAND XDDS'OUTPUT'PRIORITY > <<07438>>20415000
                                        XDDH'DEV'OUTFENCE))    <<07438>>20420000
                        THEN                                            20425000
                           IF  (NOT (SP))                               20430000
                           OR  XDDS'SPOOFLE'VT'INDEX <> 0 THEN <<06916>>20435000
                              << SATISFIED ALL QUALIFICATIONS >>        20440000
                              VISITENTRY;                               20445000
               HAVE'SUBENTRY := NEXTENTRY;                     <<07438>>20450000
               END;    << This loop processes one subentry. >> <<07438>>20455000
            << DONE SCAN OF CHAIN >>                                    20460000
            RANK := 0;                                                  20465000
            END                                                         20470000
         UNTIL NOT NEXTHEAD  OR  STOP;                         <<07438>>20475000
      END;    <<QUALIFIED VISITING>>                                    20480000
                                                                        20485000
   RELSIR (XDDSIR, SAVESIR);                                            20490000
   IF STOP THEN FATALERROR;                                    <<00548>>20495000
                                                                        20500000
<< PRINT PHASE >>                                                       20505000
                                                                        20510000
   IF ((TOTAL := STCOUNTS(XDDS'ACTIVE) + STCOUNTS(XDDS'READY)  <<06744>>20515000
      + STCOUNTS(XDDS'OPEN) + STCOUNTS(XDDS'LOCKED)) <> 0)     <<06744>>20520000
         AND  (NOT (STATUS))  THEN                                      20525000
      BEGIN    <<PRINT FILE INFO>>                                      20530000
      WRITE (0, 0);                                                     20535000
      GENMSG(CIGENERALMSGSET, SHOWFHEADER);  <<PUT OUT HEADING><<U.RAO>>20540000
      NEXTLOC := 0;  <<LOC OF NEXTENTRY IN DST>>               <<00548>>20545000
      WHILE GETENTRY (XDD'SUBENTRY, DSTNUM,                    <<07438>>20550000
                      XDD0'SUBENTRY'LENGTH) DO                 <<07438>>20555000
         BEGIN   << WHIlE loop processes one subentry.      >> <<07438>>20560000
         OBUF := "  ";                                                  20565000
         MOVE OBUF (1) := OBUF, (OBUFMAX);                              20570000
                                                                        20575000
         << DEV/CL>>                                                    20580000
         DEVSPEC (IF XDDS'CLASS THEN -XDDS'DEVICE              <<06744>>20585000
               ELSE XDDS'DEVICE, OBUFB (POSDEVCL));            <<06744>>20590000
                                                                        20595000
         << DEVICE FILE ID >>                                           20600000
         OBUFB (POSDFID) := "#";                                        20605000
         OBUFB (POSDFID +1) := IF OUT THEN "O" ELSE "I";                20610000
         ASCII (XDDS'DFID'NUMBER.(1:15), 10,                   <<06744>>20615000
                OBUFB (POSDFID +2));                           <<06744>>20620000
                                                                        20625000
         << JOB NUM >>                                                  20630000
         IF XDDS'JOB'NUMBER <> 0 THEN                          <<06744>>20635000
            BEGIN    <<NOT INTRO/READY :DATA>>                          20640000
            OBUFB (POSJNUM) := "#";                                     20645000
            OBUFB (POSJNUM +1) :=                                       20650000
                  IF XDDS'JOB'TYPE <= XDDS'SESSION THEN "S"    <<06744>>20655000
                  ELSE "J";                                    <<06744>>20660000
            JPRIME := 0;                                                20665000
            IF NOT (XDDS'SESSION <= INTEGER(XDDS'JOB'TYPE) <=  <<06744>>20670000
                XDDS'JOB)                                      <<06744>>20675000
               THEN                                            <<06744>>20680000
               BEGIN                                                    20685000
               JPRIME := 1;                                             20690000
               OBUFB(POSJNUM+2) := "'";                                 20695000
               END;                                                     20700000
            ASCII (XDDS'JOB'NUMBER,10, OBUFB (POSJNUM +2 +     <<06744>>20705000
                   JPRIME));                                   <<06744>>20710000
            END;                                                        20715000
                                                                        20720000
         << FILE NAME >>                                                20725000
         MOVE OBUFB(POSFNAME) := XDDSB'FILE'NAME, (8);         <<07438>>20730000
                                                                        20735000
         << STATE >>                                                    20740000
         MOVE OBUFB(POSSTATE):=STATES(XDDS'SPOOL'STATE*6),(6); <<06744>>20745000
                                                                        20750000
         << FORMS >>                                                    20755000
         IF ODDS'FORMS'IN'FILE THEN OBUFB (POSFORMS) := "F";   <<06744>>20760000
                                                                        20765000
         << SPOOFLE EXTENSION >>                                        20770000
         IF XDDS'SPOOFLE'VT'INDEX <> 0 THEN                    <<06916>>20775000
            BEGIN    <<SPOOFLE>>                                        20780000
            TOS := 0;                                                   20785000
            TOS := XDDS'NUMBER'EXTENTS;                        <<06744>>20790000
            IF = THEN TOS := TOS+2;                                     20795000
            TOS := LOGICAL(TOS-1) ** LOGICAL (SYSSPEXTNTSEC);  <<07438>>20800000
            TOS := TOS+DOUBLE(XDDS'LAST'EXTENT'SIZE);          <<06744>>20805000
            LEN := DASCII (*, 10, SPACEBUF);                            20810000
            MOVE OBUFB (POSSPACE) := SPACEBUF (LEN-1), (-LEN);          20815000
                                                                        20820000
            << OUTPUT SPOOFLE EXTENSION >>                              20825000
            IF OUT THEN                                                 20830000
               BEGIN                                                    20835000
                                                                        20840000
               << RANK >>                                               20845000
               IF OD'RANK <> 0 THEN                            <<07438>>20850000
                  ASCII (OD'RANK, -10, OBUFB(POSRANK));        <<07438>>20855000
                                                                        20860000
               << DEFERRED AND OUTPRI >>                                20865000
               MOVEFROMDSEG (XDD'HEAD, XDD'DST,                <<07438>>20870000
                  XDDS'HEAD'INDEX * XDD0'HEAD'LENGTH,          <<07438>>20875000
                  XDD0'HEAD'LENGTH);                           <<07438>>20880000
               IF XDDS'OUTPUT'PRIORITY <= XDD0'SYSTEM'OUTFENCE <<07438>>20885000
                  AND (XDDH'DEV'OUTFENCE = 0                   <<07438>>20890000
                      OR XDDS'OUTPUT'PRIORITY <=               <<07438>>20895000
                         XDDH'DEV'OUTFENCE)                    <<07438>>20900000
                  THEN OBUFB (POSDEFPRI) := "D";               <<07438>>20905000
               ASCII (XDDS'OUTPUT'PRIORITY, -10,               <<06744>>20910000
                      OBUFB (POSDEFPRI +2));                   <<06744>>20915000
                                                                        20920000
               << NUM COPIES >>                                         20925000
               ASCII(ODDS'NUMBER'COPIES,-10,OBUFB(POSNUMC));   <<06744>>20930000
                                                                        20935000
               LEN := POSNUMC +1;                                       20940000
               END    <<OUTPUT SPOOFLE EXTENSION>>                      20945000
            ELSE                                                        20950000
               LEN := POSSPACE +1;                                      20955000
            END    <<SPOOFLE EXTENSION>>                                20960000
         ELSE                                                           20965000
            BEGIN    <<CALC PRINT LENGTH: NO EXTENSION>>                20970000
            SCAN OBUFB (POSSTATE) UNTIL " ", 1;                         20975000
            LEN := TOS -@OBUFB;                                         20980000
            END;                                                        20985000
                                                                        20990000
         WRITE (-LEN, 0);                                               20995000
         IF (XDDS'JOB'NUMBER = 0) THEN                         <<06744>>21000000
            BEGIN    <<ACTIVE/READY :DATA>>                             21005000
            OBUF := "  ";                                               21010000
            MOVE OBUF (1) := OBUF, ((POSJNAME +1) &ASR(1));             21015000
            TOS := @OBUFB(POSJNAME) +FORMNAME(2,OBUFB          <<02.EB>>21020000
               (POSJNAME),XDDSB'JOB'NAME,XDDSB'USER'NAME,      <<06744>>21025000
                XDDSB'ACCOUNT'NAME,                            <<06744>>21030000
               XDD'BSUBENTRY);<<JOBN,USERN,ACCTN>>             <<06744>>21035000
            MOVE BPS0 := "; ", 2;                                       21040000
            MOVE * := XDDSB'FILE'NAME, (8);                    <<07438>>21045000
            LEN := TOS - @OBUFB;                               <<07438>>21050000
            WRITE (-LEN, 0);                                   <<07438>>21055000
            END;     << ACTIVE/READY :DATA                  >> <<07438>>21060000
         END;    << WHILE loop processes one subentry.      >> <<07438>>21065000
                                                                        21070000
      WRITE (0, 0);                                                     21075000
      END;                                                              21080000
                                                                        21085000
                                                                        21090000
<< SUMMARY >>                                                           21095000
   IF  STATUS  OR  (TOTAL > 1)  THEN                                    21100000
      BEGIN    <<PRINT SUMMARY INFO>>                                   21105000
      IF NOT STATUS AND (NUMPARMS>0) THEN  <<SUBSET>>          <<U.RAO>>21110000
         GENMSG(CIGENERALMSGSET,SHOWFFILECNTDSP,%10000,TOTAL)  <<U.RAO>>21115000
      ELSE   <<ALL>>                                           <<U.RAO>>21120000
         GENMSG(CIGENERALMSGSET,SHOWFFILECNT,%10000,TOTAL);    <<U.RAO>>21125000
      IF STATE = NOSTATE THEN                                           21130000
         BEGIN    <<ALL STATES DISPLAYED>>                              21135000
                                                                        21140000
         << ACTIVE >>                                                   21145000
         GENMSG(CIGENERALMSGSET,SHOWFACTIVECNT,%10000,         <<U.RAO>>21150000
            STCOUNTS(XDDS'ACTIVE));                            <<06744>>21155000
                                                                        21160000
         << READY >>                                                    21165000
         GENMSG(CIGENERALMSGSET, SHOWFREADYCNT, %11100,        <<U.RAO>>21170000
            STCOUNTS(XDDS'READY), SPCOUNTS(XDDS'READY),        <<06744>>21175000
            DEFCOUNTS(XDDS'READY));                            <<06744>>21180000
                                                                        21185000
         << OPENED >>                                                   21190000
         GENMSG(CIGENERALMSGSET, SHOWFOPENEDCNT, %11000,       <<U.RAO>>21195000
            STCOUNTS(XDDS'OPEN), SPCOUNTS(XDDS'OPEN));         <<06744>>21200000
                                                                        21205000
         << LOCKED>>                                                    21210000
         GENMSG(CIGENERALMSGSET, SHOWFLOCKEDCNT, %11000,       <<U.RAO>>21215000
            STCOUNTS(XDDS'LOCKED), SPCOUNTS(XDDS'LOCKED));     <<06744>>21220000
                                                                        21225000
         END                                                            21230000
      ELSE                                                              21235000
         IF STATE=XDDS'READY THEN <<JUST PRINT NUMBER READY>>  <<06744>>21240000
            GENMSG(CIGENERALMSGSET, SHOWFDEFCNT, %10000,       <<U.RAO>>21245000
               DEFCOUNTS(XDDS'READY));                         <<06744>>21250000
                                                                        21255000
      << NUM SPOOFLES >>                                                21260000
      GENMSG(CIGENERALMSGSET, SHOWFSPOOFLECNT, %12000,         <<U.RAO>>21265000
        SPCOUNTS(XDDS'ACTIVE) + SPCOUNTS(XDDS'READY)           <<06744>>21270000
        + SPCOUNTS(XDDS'OPEN) + SPCOUNTS(XDDS'LOCKED),         <<06744>>21275000
        @SPSPACE);                                             <<06744>>21280000
      END                                                               21285000
   ELSE                                                                 21290000
      IF TOTAL = 0 THEN                                                 21295000
         GENMSG(CIGENERALMSGSET, SHOWFNOSUCHFLS);  <<NO SUCH FI<<U.RAO>>21300000
   IF OUT THEN                                                          21305000
      BEGIN   << Show system outfence, any device outfences >> <<07438>>21310000
      GENMSG (CIGENERALMSGSET, SHOWFOUTFENCE, %10000,          <<07438>>21315000
              XDD0'SYSTEM'OUTFENCE);                           <<07438>>21320000
                                                               <<07438>>21325000
<< Copy the head entry area of ODD to our extra DST.        >> <<07438>>21330000
                                                               <<07438>>21335000
      SAVESIR := GETSIR (XDDSIR);                              <<07438>>21340000
      DSTLENGTH := XDD0'SUBENTRY'AREA;                         <<07438>>21345000
      @LASTHEADP := XDD0'SUBENTRY'AREA - XDD0'HEAD'LENGTH;     <<07438>>21350000
      MOVEDSEG (DSTNUM, 0, XDD'DST, 0, DSTLENGTH);             <<07438>>21355000
      RELSIR (XDDSIR, SAVESIR);                                <<07438>>21360000
      HEAD'ENTRY'OFFSET := XDD'CLASS'ENTRY + XDD0'HEAD'LENGTH; <<07438>>21365000
      DO BEGIN                                                 <<07438>>21370000
         MOVEFROMDSEG (XDD'HEAD, DSTNUM, HEAD'ENTRY'OFFSET,    <<07438>>21375000
                       XDD0'HEAD'LENGTH);                      <<07438>>21380000
         IF XDDH'DEV'OUTFENCE <> 0 THEN                        <<07438>>21385000
            GENMSG (CIGENERALMSGSET, SHOWFDEVFENCE, %11000,    <<07438>>21390000
                    XDDH'DEV'OUTFENCE, XDDH'LDEV);             <<07438>>21395000
         END                                                   <<07438>>21400000
        UNTIL (HEAD'ENTRY'OFFSET := HEAD'ENTRY'OFFSET +        <<07438>>21405000
               XDD0'HEAD'LENGTH) > LOGICAL (@LASTHEADP);       <<07438>>21410000
      END;    << Show system outfence, any device outfences >> <<07438>>21415000
                                                                        21420000
LEAVE:                                                                  21425000
   IF DSTNUM <> 0 THEN FREEDSEG (DSTNUM,0);;                   <<00548>>21430000
   END;    <<SHOWFILES>>                                                21435000
$PAGE "   ***   CONSSHOWIN / CONSSHOWOUT   ***"                <<07438>>21440000
$CONTROL SEGMENT = SPOOLCOMS2                                  <<07438>>21445000
                                                                        21450000
LOGICAL PROCEDURE CONSSHOWIN  <<& CONSSHOWOUT>>  (PARMSTRING);          21455000
   BYTE ARRAY PARMSTRING;                                               21460000
   OPTION PRIVILEGED,UNCALLABLE;                               <<00179>>21465000
BEGIN                                                                   21470000
   ENTRY CONSSHOWOUT;                                                   21475000
   LOGICAL OUT := TRUE;                                                 21480000
   INTEGER PN;                                                          21485000
                                                                        21490000
   OUT := FALSE;                                                        21495000
CONSSHOWOUT:                                                            21500000
   CONSSHOWIN := (SHOWFILES (PARMSTRING, PN, 0, OUT) = 0);              21505000
   END;    <<CONSSHOWIN/ CONSSHOWOUT>>                                  21510000
$PAGE "   ***   CXSHOWIN / CXSHOWOUT   ***"                    <<07438>>21515000
$CONTROL SEGMENT = SPOOLCOMS2                                  <<07438>>21520000
                                                                        21525000
PROCEDURE CXSHOWIN  <<AND CXSHOWOUT>>  (PARMSP, ERRNUM, PARMNUM);       21530000
   BYTE ARRAY PARMSP;                                                   21535000
   INTEGER ERRNUM, PARMNUM;                                             21540000
   OPTION PRIVILEGED, UNCALLABLE;                                       21545000
BEGIN                                                                   21550000
   ENTRY CXSHOWOUT;                                                     21555000
                                                                        21560000
   LOGICAL OUT := TRUE;                                                 21565000
   INTEGER PCBGLOBLOC;                                         <<06744>>21570000
   LOGICAL ARRAY JITARR(0:JIT'ENTRY'SIZE-1);                   <<07438>>21575000
   LOGICAL JOBNUMBER;                                          <<07438>>21580000
   INTEGER ARRAY QARRAY(*)=Q+0;                                <<06744>>21585000
                                                               <<06744>>21590000
   SUBROUTINE DEF'MOVEFROMDSEG;                                <<07438>>21595000
                                                                        21600000
   OUT := FALSE;                                                        21605000
CXSHOWOUT:                                                              21610000
   PXGLOBAL;                                                   <<06744>>21615000
   MOVEFROMDSEG (JITARR, PXG'JITDST, 0, JIT'ENTRY'SIZE);       <<07438>>21620000
   JOBNUMBER := JITJOBNUMBER LOR (JITJSTYPE & LSL (14));       <<07438>>21625000
   ERRNUM:=SHOWFILES(PARMSP,PARMNUM,IF MASTEROP THEN 0         <<06744>>21630000
     ELSE JOBNUMBER,OUT);                                      <<06744>>21635000
   END;    <<CXSHOWIN/CXSHOWOUT>>                                       21640000
$PAGE "   ***   CONSALTFILE / CONSALTJOB   ***"                         21645000
$CONTROL SEGMENT= SPOOLCOMS1                                            21650000
                                                                        21655000
                                                                        21660000
LOGICAL PROCEDURE CONSALTFILE <<AND CONSALTJOB>> (PARMSTRING);          21665000
   BYTE ARRAY PARMSTRING;                                               21670000
   OPTION PRIVILEGED, UNCALLABLE;                                       21675000
BEGIN                                                                   21680000
   ENTRY CONSALTJOB;                                                    21685000
   LOGICAL           FILEFLAG := FALSE;<<COMMAND INDICATOR>>            21690000
                                                                        21695000
<< DECLARATIONS >>                                                      21700000
                                                                        21705000
<< PARSE >>                                                             21710000
   EQUATE            MAXPARMS = 7;                                      21715000
   P'DECLARATIONS;                                                      21720000
   EQUATE            KEYLEN = 20;                                       21725000
   BYTE ARRAY        KEYWORDSP (*) = PB :=                              21730000
                        9, 5, "INPRI", 1, 0,                            21735000
                        10, 6, "OUTPRI", 1, 1,                          21740000
                        10, 6, "COPIES", 2, 1,                          21745000
                        10, 6, "OUTDEV", 3, 3,                          21750000
                        0;                                              21755000
   ARRAY             KEYWORDSPW (*) = KEYWORDSP;                        21760000
   ARRAY             KEYWORDSW (0:KEYLEN -1);                           21765000
   BYTE ARRAY        KEYWORDS (*) = KEYWORDSW;                          21770000
   BYTE POINTER      KEYDEFN;                                           21775000
                                                                        21780000
<< PARSE RESULT >>                                                      21785000
   INTEGER           TARGET,           <<DEV FILE ID /OR/ JOB NUM>>     21790000
                     DFID = TARGET,                                     21795000
                     JOBNUM = TARGET;                                   21800000
   INTEGER           PRI  := -1,       <<NEW INPRI/OUTPRI>>             21805000
                     INPRI = PRI,                                       21810000
                     OUTPRI = PRI,                                      21815000
                     NUMCOPIES := 0,   <<NEW COPIES>>                   21820000
                     DEV := 0;         <<NEW OUTDEV>>                   21825000
   INTEGER ARRAY     DEVINFO (0:SIZE'OF'GETDEVINFO)=Q;         <<06744>>21830000
   EQUATE            OUTTYPE = 4;      <<DEV MUST B OUTPUT>>            21835000
   LOGICAL           RELINK := FALSE,<<ODD RELINK NECESSARY?>> <<06744>>21840000
                     CLASS'FLAG;                               <<06744>>21845000
                                                                        21850000
<< SEARCH PARAMETERS >>                                                 21855000
   INTEGER           SAVESIR;          <<GETSIR RESULT>>                21860000
   INTEGER           VDEV;                                              21865000
   LOGICAL POINTER   LDT;                                      <<06744>>21870000
   INTEGER           LDT'INDEX;                                <<06744>>21875000
   INTEGER           SAVSIR;                                            21880000
   INTEGER           HEADX;                                             21885000
   INTEGER POINTER   ENTRYP,           <<RUNNING PNTR>>                 21890000
                     LIMITP,           <<TABLE END PNTR>>               21895000
                     HEADP = LIMITP;   <<ODD HEAD PNTR>>                21900000
   LOGICAL POINTER   ENTRYPL  = ENTRYP;                                 21905000
                                                               <<06744>>21910000
   LOGICAL POINTER   XDD := 0,                                 <<06744>>21915000
                     XDD'HEAD,                                 <<06744>>21920000
                     XDD'SUBENTRY;                             <<06744>>21925000
   BYTE    POINTER   XDD'BSUBENTRY;                            <<06744>>21930000
   DOUBLE  POINTER   XDD'DSUBENTRY;                            <<06744>>21935000
                                                               <<06744>>21940000
   INTEGER ARRAY     JMATARR(*) = DB+0;                        <<06744>>21945000
   INTEGER           JMATINX,                                  <<06744>>21950000
                     JMATLIMIT;                                <<06744>>21955000
                                                                        21960000
<< >>                                                                   21965000
   FILEFLAG := TRUE;                                                    21970000
CONSALTJOB:                                                             21975000
                                                                        21980000
   CONSALTFILE := FALSE;    <<INITIALIZE>>                              21985000
   MYCOMMAND (PARMSTRING, , MAXPARMS, NUMPARMS, PARMS(1));              21990000
   IF  <>  OR  (NUMPARMS < 3)  THEN RETURN;                             21995000
   PARM := PARMS (PNUM := 1);                                           22000000
   IF  (PLEN < 3)  OR  (PP <> "#")  THEN RETURN;                        22005000
   TOS := BINARY (PP(2), PLEN -2);                                      22010000
   IF  <>  OR  ((TARGET := TOS) < 0)  THEN RETURN;                      22015000
   IF FILEFLAG THEN                                                     22020000
      BEGIN                                                             22025000
      IF PP(1) <> "O" THEN RETURN;                                      22030000
      TARGET.(0:1) := 1;                                                22035000
      END                                                               22040000
   ELSE                                                                 22045000
      BEGIN                                                             22050000
      IF  (PP(1) <> "J")  OR  (LOGICAL (TARGET).(1:1))  THEN RETURN;    22055000
      TARGET.(0:2) := 2;                                                22060000
      END;                                                              22065000
                                                                        22070000
   << GOT TARGET (DFID OR JNUM); PROCESS KEYWORDS >>                    22075000
   MOVE KEYWORDSW := KEYWORDSPW, (KEYLEN);                              22080000
   WHILE PDEL = SEMI DO                                                 22085000
      BEGIN                                                             22090000
      PARM := PARMS (PNUM :=  PNUM +1);                                 22095000
      IF  (PLEN = 0)  OR  (PDEL <> EQUAL)  THEN RETURN;                 22100000
      IF SEARCH (PP, PLEN, KEYWORDS, KEYDEFN) = 0 THEN RETURN;          22105000
      PARM := PARMS (PNUM := PNUM +1);                                  22110000
      IF PLEN = 0 THEN RETURN;                                          22115000
      << CHECK IF ALLOWED 4 THIS COMMAND >>                             22120000
      IF  (KEYDEFN (1) <> 3)                                            22125000
            AND  (INTEGER (KEYDEFN(1)) <> INTEGER (FILEFLAG.(15:1)))    22130000
               THEN RETURN;                                             22135000
      XREG := KEYDEFN;                                                  22140000
      KEYDEFN := 0;    <<SIGNAL FOR DUPLICATE>>                         22145000
      CASE * XREG OF                                                    22150000
         BEGIN                                                          22155000
                                                                        22160000
<< DUPLICATE >>                                                         22165000
            RETURN;                                                     22170000
                                                                        22175000
<< INPRI/OUTPRI >>                                                      22180000
            BEGIN                                                       22185000
            PRI := BINARY (PP, PLEN);                                   22190000
            IF <> THEN RETURN;                                          22195000
            IF NOT (0 <= PRI <= 14) THEN RETURN;                        22200000
            RELINK := TRUE;    <<ENTRY MUST BE RELINKED>>               22205000
            END;                                                        22210000
                                                                        22215000
<< NUM COPIES >>                                                        22220000
            BEGIN                                                       22225000
            NUMCOPIES := BINARY (PP, PLEN);                             22230000
            IF <> THEN RETURN;                                          22235000
            IF NOT (1 <= NUMCOPIES <= 127) THEN RETURN;                 22240000
            END;                                                        22245000
                                                                        22250000
<< OUTDEV >>                                                            22255000
            BEGIN                                                       22260000
            IF (GETDEVINFO (PP, DEVINFO) <> 0) THEN                     22265000
               RETURN;                                                  22270000
            IF FILEFLAG THEN                                            22275000
               BEGIN                                                    22280000
               IF SPOOLEDDEV (G'DCT'INDEX).(14:2)= 0           <<06744>>22285000
                  THEN RETURN;                                 <<06744>>22290000
               END                                                      22295000
            ELSE                                                        22300000
               IF DEVINFO (G'LDT'ACCESS'TYPE) <> OUTTYPE       <<06744>>22305000
              THEN RETURN;                                     <<06744>>22310000
            IF G'DCT'INDEX < 0 THEN                            <<06744>>22315000
               BEGIN                                           <<06744>>22320000
               CLASS'FLAG := TRUE;                             <<06744>>22325000
               DEV := G'DCT'INDEX;                             <<06744>>22330000
               END                                             <<06744>>22335000
            ELSE                                               <<06744>>22340000
               BEGIN                                           <<06744>>22345000
               CLASS'FLAG := FALSE;                            <<06744>>22350000
               DEV := G'DCT'INDEX;                             <<06744>>22355000
               END;                                            <<06744>>22360000
            RELINK := TRUE;    <<MUST B RELINKED (ODD)>>                22365000
            END    <<LAST CASE STATEMENT>>                              22370000
                                                                        22375000
         END;                                                           22380000
      END;                                                              22385000
   IF PDEL <> CR THEN RETURN;                                           22390000
                                                                        22395000
   << DONE PARSE >>                                                     22400000
                                                                        22405000
   IF FILEFLAG THEN                                                     22410000
      BEGIN                                                             22415000
      SAVSIR := GETSIR(LDT'SIR);                               <<06744>>22420000
      EXCHANGEDB (ODD'DST);                                    <<06744>>22425000
      SAVESIR := GETSIR (ODD'SIR);                             <<06744>>22430000
      @XDD'SUBENTRY := XDD0'SUBENTRY'AREA;                     <<06744>>22435000
      @LIMITP := XDD0'CURRENT'SECTORS * SECTOR'SIZE -          <<06744>>22440000
                 SIZE'OF'XDD'SUBENTRY;                         <<06744>>22445000
      DO    <<FIND SUBENTRY>>                                           22450000
      UNTIL (XDD'SUBENTRY <> 0) AND (INTEGER(XDDS'DFID'NUMBER) <<06744>>22455000
         = DFID)                                               <<06744>>22460000
            OR ((@XDD'SUBENTRY := @XDD'SUBENTRY +              <<06744>>22465000
                SIZE'OF'XDD'SUBENTRY) > @LIMITP);              <<06744>>22470000
      IF  =  <<GOT REQUESTED ENTRY. RIGHT TYPE/STATE?>>                 22475000
            AND  (XDDS'SPOOFLE'VT'INDEX <>0)      <<SPOOFLE>>  <<06916>>22480000
               AND(XDDS'SPOOL'STATE<>XDDS'ACTIVE)<<OPN OR RDY>><<06744>>22485000
                  THEN                                                  22490000
         BEGIN    <<EXISTENT OPENED/READY SPOOFLE>>                     22495000
         IF NUMCOPIES > 0 THEN ODDS'NUMBER'COPIES := NUMCOPIES;<<06744>>22500000
         IF RELINK THEN                                                 22505000
            BEGIN    <<OUTPRI AND/OR DEVICE => DELINK & RELINK>>        22510000
            @XDD'HEAD := XDDS'HEAD'INDEX * SIZE'OF'XDD'HEAD;   <<06744>>22515000
            TOS := @XDDH'FIRST'SUBENTRY;                       <<06744>>22520000
            DELINKENTRY (*, XDD'SUBENTRY);                     <<06744>>22525000
            IF DEV <> 0 THEN                                            22530000
               BEGIN    <<NEW DEVICE>>                                  22535000
               XDDS'DEVICE := DEV;                             <<06744>>22540000
               XDDS'CLASS := CLASS'FLAG;                       <<07438>>22545000
               @XDD'HEAD := XDD'CLASS'ENTRY * SIZE'OF'XDD'HEAD;<<06744>>22550000
               IF NOT XDDS'CLASS THEN                          <<06744>>22555000
                  << DEVICE: FIND HEAD >>                               22560000
                  DO @XDD'HEAD := @XDD'HEAD+SIZE'OF'XDD'HEAD   <<06744>>22565000
                  UNTIL INTEGER(XDDH'LDEV) = DEV;              <<06744>>22570000
               XDDS'HEAD'INDEX := @XDD'HEAD/SIZE'OF'XDD'HEAD;  <<06744>>22575000
               HEADX := @XDD'HEAD / SIZE'OF'XDD'HEAD;          <<06744>>22580000
               VDEV := XDDS'VIRTUAL'LDEV;                      <<06744>>22585000
               IF XDDS'SPOOL'STATE=XDDS'OPEN AND VDEV<>0 THEN  <<06744>>22590000
                  BEGIN                                                 22595000
                  EXCHANGEDB(LDT'DST);                         <<06744>>22600000
                  @LDT := 0;                                   <<06744>>22605000
                  LDT'INDEX := VDEV*SIZE'OF'LDT'ENTRY;         <<06744>>22610000
                  LDT'XDD'HEAD'INDEX := HEADX;                 <<07438>>22615000
                  EXCHANGEDB(ODD'DST);                         <<06744>>22620000
                  END;                                                  22625000
               END;                                                     22630000
            IF PRI >= 0 THEN XDDS'OUTPUT'PRIORITY := PRI;      <<06744>>22635000
            SLINKXDD (XDDS'HEAD'INDEX, XDD'SUBENTRY);          <<06744>>22640000
            END;                                                        22645000
         RELSIR (ODD'SIR, SAVESIR);                            <<06744>>22650000
         IF RELINK THEN                                                 22655000
            <<AWAKE APPROPRIATE SPOOLER(S)>>                            22660000
            SROOSTER (IF XDDS'CLASS THEN -XDDS'DEVICE          <<06744>>22665000
                  ELSE XDDS'DEVICE);                           <<06744>>22670000
         CONSALTFILE := TRUE;                                           22675000
         END                                                            22680000
      ELSE                                                              22685000
         RELSIR (ODD'SIR, SAVESIR);                            <<06744>>22690000
      RELSIR(LDT'SIR,SAVSIR);                                  <<06744>>22695000
      END    <<CONSALTFILE>>                                            22700000
   ELSE                                                                 22705000
      BEGIN    <<ALTER JMAT ENTRY>>                                     22710000
      EXCHANGEDB (JMATDST);                                             22715000
      SAVESIR := GETSIR (JMATSIR);                                      22720000
      JMATINX := JMATENTRYPTR;                                 <<06744>>22725000
      JMATLIMIT := JMATCURSIZE *SECTOR'SIZE-JMATENTRYSIZE;     <<06744>>22730000
      DO                                                                22735000
      UNTIL  (JMATARR(JMATINX) <> 0)                           <<06744>>22740000
            AND  (JMATJOBSTATE <> JOBERR)                      <<06744>>22745000
               AND  (JMATJSNO = JOBNUM)                        <<06744>>22750000
         OR ((JMATINX:= JMATINX + JMATENTRYSIZE) >= JMATLIMIT);<<07438>>22755000
      IF = THEN                                                         22760000
         << FOUND ENTRY: MUST BE INTRO OR WAIT >>                       22765000
         IF  (JMATJOBSTATE = JOBINTRO)                         <<06744>>22770000
               OR  (JMATJOBSTATE = JOBWAIT) THEN               <<06744>>22775000
            BEGIN    <<EXISTENT AND IN PERMISSABLE STATE>>              22780000
            IF DEV <> 0 THEN                                            22785000
               BEGIN                                                    22790000
               JMATCBIT := IF CLASS'FLAG THEN 1 ELSE 0;        <<06744>>22795000
               JMATJLISTDEV := DEV;                            <<06744>>22800000
               IF (JMATJOBSTATE = JOBWAIT) AND (PRI < 0) THEN  <<06744>>22805000
                  << NEW DEV => MAYBE CAN START;                        22810000
                     PRI NOT SUPPLIED, SO AWAKE UCOP HERE. >>           22815000
                  BEGIN                                                 22820000
                  XREG := JOBSYNCADDR;                                  22825000
                  DISABLE;                                              22830000
                  ABSOLUTE (XREG).(JOBREADY'F) := TRUE;                 22835000
                  ENABLE;                                               22840000
                  AWAKE (SYSUCOPPCB, JUNKWAIT, 0);             <<07438>>22845000
                  END;                                                  22850000
               END;                                                     22855000
            IF PRI >= 0 THEN                                            22860000
               BEGIN    <<CHANGE INPRI>>                                22865000
               JMATINPRI := PRI;                               <<06744>>22870000
               IF JMATJOBSTATE = JOBWAIT THEN                  <<06744>>22875000
                  BEGIN    <<CHANGED WAITING'S INPRI: RESCHEDULE>>      22880000
                  TOS:=JMATHEADPTR;                            <<06744>>22885000
                  DELINK'JMAT (JMATINX);                       <<07438>>22890000
                  JMATJOBSTATE := JOBINTRO;                    <<06744>>22895000
                  SCHEDULEJOB' (JMATINX);                      <<06744>>22900000
                  END;                                                  22905000
               END;                                                     22910000
            CONSALTFILE := TRUE;                                        22915000
            END;                                                        22920000
      RELSIR (JMATSIR, SAVESIR);                                        22925000
      END;    <<CONSALTJOB>>                                            22930000
                                                                        22935000
   EXCHANGEDB (0);                                                      22940000
   END;    <<CONSALTFILE/CONSALTJOB>>                                   22945000
$PAGE "   ***   DELETEDEVFILE   ***"                           <<07438>>22950000
$CONTROL SEGMENT = SPOOLCOMS1                                  <<07438>>22955000
                                                               <<07438>>22960000
INTEGER PROCEDURE DELETEDEVFILE (DFID'OR'JOB, BYJOB);          <<07438>>22965000
   VALUE   DFID'OR'JOB, BYJOB;                                 <<07438>>22970000
   INTEGER DFID'OR'JOB;                                        <<07438>>22975000
   LOGICAL BYJOB;                                              <<07438>>22980000
   OPTION  PRIVILEGED, UNCALLABLE;                             <<07438>>22985000
                                                               <<07438>>22990000
BEGIN COMMENT --                                               <<07438>>22995000
  DELETEDEVFILE is used to delete a spool file (or an XDD  en- <<07438>>23000000
try if no file exists).  It currently has four callers:        <<07438>>23005000
1.  DELETEJOB in the OPCOMMAND module calls us as part of  the <<07438>>23010000
    ABORTJOB  command when it aborts a WAITing (non-executing) <<07438>>23015000
    job.  We delete the corresponding IDD entry.               <<07438>>23020000
2.  CXDELETESPOOLFILE calls us to delete certain READY or  AC- <<07438>>23025000
    TIVE spool files (more on this below).                     <<07438>>23030000
3.  The MRJE subsystem has a hook in here (through MRJEDELETE) <<07438>>23035000
    but it has to play by the rules too.                       <<07438>>23040000
4.  The code for the obsolete console command (=DELETE)  calls <<07438>>23045000
    us, but is never invoked.                                  <<07438>>23050000
  The flag parameter BYJOB is set TRUE by DELETEJOB, FALSE  by <<07438>>23055000
all  other  callers.  It  restricts our search to the IDD, and <<07438>>23060000
asks us to match the entry whose job type and job  number  are <<07438>>23065000
contained  in  the  DFID'OR'JOB  parameter in MPE4 format [Job <<S7962>>23070000
Type in (0:2), Job Number in (2:14)].  When it is  FALSE,  the <<07438>>23075000
DFID'OR'JOB parameter contains a DFID to be matched in the ap- <<07438>>23080000
propriate XDD (if DFID.(0:1) is on, the ODD, else the IDD).    <<07438>>23085000
  We will delete a file only if it meets these tests:          <<07438>>23090000
1.  Any file requested by DELETEJOB, since it only makes  safe <<07438>>23095000
    requests.                                                  <<07438>>23100000
2.  Any file which is in the READY state except for a STREAMed <<07438>>23105000
    job file [an IDD file named $STDIN(X)].                    <<07438>>23110000
3.  Any ACTIVE file for which we can successfully  AWAKEn  its <<07438>>23115000
    spooler  process.  There  is  one  kind of ACTIVE file for <<07438>>23120000
    which no spooler process exists.  This is a file currently <<07438>>23125000
    being created by the input STREAMer.  See below  for  more <<07438>>23130000
    comments on this situation.                                <<07438>>23135000
  DELETEDEVFILE returns one of the following values:           <<07438>>23140000
    0 -- No error, file deleted successfully.                  <<07438>>23145000
    1 -- Not returned (maybe it was once).                     <<07438>>23150000
    2 -- Couldn't match the requested DFID'OR'JOB.             <<07438>>23155000
    3 -- Matched, but file was in the wrong state (e.g. OPEN). <<07438>>23160000
    4 -- Matched, but was a $STDIN(X) file.                    <<07438>>23165000
  Implementation and maintenance note:  Although we  run  with <<07438>>23170000
DB  at the stack, and are therefore more efficient if DB is at <<07438>>23175000
the stack when we are called, we are callable  in  split-stack <<07438>>23180000
mode.  In  particular, DELETEJOB calls us with DB at the JMAT. <<07438>>23185000
Therefore, all local (Q-relative) arrays MUST be direct.       <<07438>>23190000
;                                                              <<07438>>23195000
EQUATE                                                         <<07438>>23200000
   NO'ERROR           =  0,  << DELETEDEVFILE return values >> <<07438>>23205000
   << ???             =  1,                                 >> <<07438>>23210000
   NO'MATCH           =  2,                                    <<07438>>23215000
   WRONG'STATE        =  3,                                    <<07438>>23220000
   CAN'T'DELETE'STDIN =  4;                                    <<07438>>23225000
                                                               <<07438>>23230000
INTEGER                                                        <<07438>>23235000
   DEV                    ,                                    <<07438>>23240000
   DFID              :=  0,                                    <<07438>>23245000
   DST'AT'ENTRY      := -1,                                    <<07438>>23250000
   ENTRY'ADDRESS          ,  << Moving offset into XDD.     >> <<07438>>23255000
   ERRNUM                 ,  << Retnd from SENDSPOOLERMSG.  >> <<07438>>23260000
   JOB               :=  0,                                    <<07438>>23265000
   LDT'INDEX         :=  0,  << Required by INCLLDT5.       >> <<07438>>23270000
   LIMIT'ADDRESS          ,  << Last possible XDD offset.   >> <<07438>>23275000
   PCBPT                  ,  << Required by INCLPCB5.       >> <<07438>>23280000
   SAVE'LDT'SIR           ,                                    <<07438>>23285000
   SAVE'XDD'SIR           ,                                    <<07438>>23290000
   XDD'DST                ,                                    <<07438>>23295000
   XDD'SIR                ;                                    <<07438>>23300000
                                                               <<07438>>23305000
LOGICAL                                                        <<07438>>23310000
   FOUND'IT               ,                                    <<07438>>23315000
   JOB'NUMBER'AND'TYPE    ;                                    <<07438>>23320000
                                                               <<07438>>23325000
DEFINE                                                         <<07438>>23330000
   JOB'NUMBER         = JOB'NUMBER'AND'TYPE.(2:14) #,          <<07438>>23335000
   JOB'TYPE           = JOB'NUMBER'AND'TYPE.(0: 2) #,          <<07438>>23340000
   OUTPUT'DFID        = DFID < 0                   #;          <<07438>>23345000
                                                               <<07438>>23350000
LOGICAL ARRAY                                                  <<07438>>23355000
   LDT(0:SIZE'OF'LDT'ENTRY - 1)             = Q,               <<07438>>23360000
   XDD(0:SIZE'OF'XDD0 - 1)                  = Q,               <<07438>>23365000
   XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY - 1) = Q;               <<07438>>23370000
                                                               <<07438>>23375000
BYTE ARRAY                                                     <<07438>>23380000
   XDD'BSUBENTRY(*)                         = XDD'SUBENTRY;    <<07438>>23385000
                                                               <<07438>>23390000
LOGICAL POINTER                                                <<07438>>23395000
   ENTRY'ADDRESS'P = ENTRY'ADDRESS,                            <<S7962>>23400000
   PCB = SYSPCBINDEX;   << Required by INCLPCB5.            >> <<07438>>23405000
                                                               <<07438>>23410000
<< The following variables are needed for SENDSPOOLERMSG.   >> <<07438>>23415000
                                                               <<07438>>23420000
EQUATE                                                         <<07438>>23425000
   SHUT            =       0,   << Spool queue controls.    >> <<07438>>23430000
   OPEN            =       1,                                  <<07438>>23435000
   UNCHANGED       =       2,                                  <<07438>>23440000
                                                               <<07438>>23445000
   NO'DIRECTIVE    = %100000;                                  <<07438>>23450000
                                                               <<07438>>23455000
LOGICAL                                                        <<07438>>23460000
   NEW'DIRECTIVE  := NO'DIRECTIVE;                             <<07438>>23465000
                                                               <<07438>>23470000
DEFINE                                                         <<07438>>23475000
   FILE'DIRECTIVE  = NEW'DIRECTIVE.(12:4) #;                   <<07438>>23480000
                                                               <<07438>>23485000
INTEGER                                                        <<07438>>23490000
   PARMNUM;           << Not used.                          >> <<07438>>23495000
                                                               <<07438>>23500000
LOGICAL ARRAY                                                  <<07438>>23505000
   SPOOLINFO(0:3);    << Not used.                          >> <<07438>>23510000
                                                               <<07438>>23515000
                                                               <<07438>>23520000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07438>>23525000
SUBROUTINE DEF'MOVETODSEG;                                     <<07438>>23530000
PCBPT := CURPRC;   << Required by PCB $INCLUDE file.        >> <<07438>>23535000
IF SPCBXDSDST <> STACK THEN                                    <<07438>>23540000
   DST'AT'ENTRY := EXCHANGEDB (STACK);                         <<07438>>23545000
IF BYJOB THEN                                                  <<07438>>23550000
   JOB := DFID'OR'JOB                                          <<07438>>23555000
ELSE                                                           <<07438>>23560000
   DFID := DFID'OR'JOB;                                        <<07438>>23565000
IF DFID >= 0 THEN                                              <<07438>>23570000
   BEGIN   << ABORTJOB or other request to delete IDD entry >> <<07438>>23575000
   XDD'DST := IDD'DST;                                         <<07438>>23580000
   XDD'SIR := IDD'SIR;                                         <<07438>>23585000
   END     << ABORTJOB or other request to delete IDD entry >> <<07438>>23590000
ELSE                                                           <<07438>>23595000
   BEGIN                                                       <<07438>>23600000
   XDD'DST := ODD'DST;                                         <<07438>>23605000
   XDD'SIR := ODD'SIR;                                         <<07438>>23610000
   END;                                                        <<07438>>23615000
SAVE'XDD'SIR := GETSIR (XDD'SIR);                              <<07438>>23620000
MOVEFROMDSEG (XDD, XDD'DST, 0, SIZE'OF'XDD0);                  <<07438>>23625000
                                                               <<07438>>23630000
<< Find the XDD entry corresponding to the input  PARM.  If >> <<07438>>23635000
<< we're  doing  an ABORTJOB (BYJOB TRUE), we match the job >> <<07438>>23640000
<< type (job/session) and job number.  For anything else we >> <<07438>>23645000
<< use SFINDxDD to match the DFID number.                   >> <<07438>>23650000
                                                               <<07438>>23655000
IF BYJOB THEN                                                  <<07438>>23660000
   BEGIN   << ABORTJOB, match job type and number.          >> <<07438>>23665000
   ENTRY'ADDRESS := XDD0'SUBENTRY'AREA;                        <<07438>>23670000
   LIMIT'ADDRESS := XDD0'CURRENT'SECTORS * SECTOR'SIZE -       <<07438>>23675000
                    XDD0'SUBENTRY'LENGTH;                      <<07438>>23680000
   FOUND'IT := FALSE;                                          <<07438>>23685000
   WHILE ENTRY'ADDRESS <= LIMIT'ADDRESS AND NOT FOUND'IT DO    <<07438>>23690000
      BEGIN   << This loop checks one entry for job number. >> <<07438>>23695000
      MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST, ENTRY'ADDRESS,      <<07438>>23700000
                    XDD0'SUBENTRY'LENGTH);                     <<07438>>23705000
      JOB'TYPE   := XDDS'JOB'TYPE;                             <<07438>>23710000
      JOB'NUMBER := XDDS'JOB'NUMBER;                           <<07438>>23715000
      IF XDD'SUBENTRY <> XDDS'UNUSED'SUBENTRY AND              <<07438>>23720000
         JOB'NUMBER'AND'TYPE = LOGICAL (JOB) THEN              <<07438>>23725000
         FOUND'IT := TRUE                                      <<07438>>23730000
      ELSE                                                     <<07438>>23735000
         ENTRY'ADDRESS := ENTRY'ADDRESS +                      <<07438>>23740000
                          INTEGER (XDD0'SUBENTRY'LENGTH);      <<07438>>23745000
      END;    << This loop checks one entry for job number. >> <<07438>>23750000
   END     << ABORTJOB, match job type and number.          >> <<07438>>23755000
ELSE                                                           <<07438>>23760000
   BEGIN   << Some other function, match DFID.              >> <<07438>>23765000
   IF OUTPUT'DFID THEN                                         <<07438>>23770000
      FOUND'IT := SFINDODD (DFID, ENTRY'ADDRESS)               <<07438>>23775000
   ELSE                                                        <<07438>>23780000
      FOUND'IT := SFINDIDD (DFID, ENTRY'ADDRESS);              <<07438>>23785000
   IF FOUND'IT THEN                                            <<07438>>23790000
      BEGIN   << Have local copy when we leave here.        >> <<07438>>23795000
      MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST,                     <<07438>>23800000
         ENTRY'ADDRESS.(1:15), XDD0'SUBENTRY'LENGTH);          <<07438>>23805000
      END;    << Have local copy when we leave here.        >> <<07438>>23810000
   END;    << Some other function, match DFID.              >> <<07438>>23815000
                                                               <<07438>>23820000
<< The following wicked-looking test is TRUE for:           >> <<07438>>23825000
<<   1.  The ABORTJOB function (BYJOB = TRUE),              >> <<07438>>23830000
<<   2.  Any READY output file, -OR-                        >> <<07438>>23835000
<<   3.  Any READY input file which isn't $STDIN(X).        >> <<07438>>23840000
                                                               <<07438>>23845000
IF FOUND'IT THEN                                               <<07438>>23850000
   IF BYJOB                                 << 1 >>            <<07438>>23855000
      OR XDDS'SPOOL'STATE = XDDS'READY                         <<07438>>23860000
         AND (OUTPUT'DFID                   << 2 >>            <<07438>>23865000
            OR XDDSB'FILE'NAME <> "$STDIN") << 3 >>   THEN     <<07438>>23870000
      BEGIN   << Test passed, file is safe to delete.       >> <<07438>>23875000
      XDDS'SPOOL'STATE := XDDS'LOCKED;                         <<07438>>23880000
      MOVETODSEG (XDD'DST, ENTRY'ADDRESS.(1:15), XDD'SUBENTRY, <<07438>>23885000
                  XDD0'SUBENTRY'LENGTH);                       <<07438>>23890000
      RELSIR (XDD'SIR, SAVE'XDD'SIR);                          <<07438>>23895000
      DEV := XDDS'DEVICE;   << For FREEDEVICE (maybe) below >> <<07438>>23900000
      IF XDDS'SPOOFLE'VT'INDEX <> 0 THEN                       <<07438>>23905000
         BEGIN   << Ready spool file, use FSOPEN to purge.  >> <<07438>>23910000
         TOS := FSOPEN (, %305, %500, ENTRY'ADDRESS);          <<07438>>23915000
         FSCLOSE (*, 4, 0);                                    <<07438>>23920000
         END     << Ready spool file, use FSOPEN to purge.  >> <<07438>>23925000
      ELSE                                                     <<07438>>23930000
         BEGIN   << Real dev, remove XDD entry and release. >> <<07438>>23935000
         SREMOVEXDD (ENTRY'ADDRESS'P);   << Ptr req'd here. >> <<S7962>>23940000
         FREEDEVICE (DEV, TRUE);   << Wait for Device Close >> <<07438>>23945000
         END;    << Real dev, remove XDD entry and release. >> <<07438>>23950000
      DELETEDEVFILE := NO'ERROR;                               <<07438>>23955000
      END     << Test passed, file is safe to delete.       >> <<07438>>23960000
   ELSE IF XDDS'SPOOL'STATE = XDDS'ACTIVE THEN                 <<07438>>23965000
      BEGIN   << This is only other acceptable state.       >> <<07438>>23970000
      DEV := XDDS'DEVICE;                                      <<07438>>23975000
      RELSIR (XDD'SIR, SAVE'XDD'SIR);                          <<07438>>23980000
      SAVE'LDT'SIR := GETSIR (LDT'SIR);                        <<07438>>23985000
      MOVEFROMDSEG (LDT, LDT'DST, 0, SIZE'OF'LDT'ENTRY);       <<07438>>23990000
      FILE'DIRECTIVE := DELETEFILE;                            <<07438>>23995000
      IF SENDSPOOLERMSG (DEV, NEW'DIRECTIVE, UNCHANGED,        <<07438>>24000000
                         SPOOLINFO, ERRNUM, PARMNUM) THEN      <<07438>>24005000
         BEGIN   << Spooler was awakened successfully.      >> <<07438>>24010000
         RELSIR (LDT'SIR, SAVE'LDT'SIR);                       <<07438>>24015000
         DELETEDEVFILE := NO'ERROR;                            <<07438>>24020000
         END     << Spooler was awakened successfully.      >> <<07438>>24025000
      ELSE                                                     <<07438>>24030000
         BEGIN   << Had a problem waking the spooler.       >> <<07438>>24035000
         RELSIR (LDT'SIR, SAVE'LDT'SIR);                       <<07438>>24040000
         IF ERRNUM = SPOOLERBUSY THEN                          <<07438>>24045000
            CIERR (-ERRNUM)   << No "^" under error msg.    >> <<07438>>24050000
         ELSE                                                  <<07438>>24055000
            BEGIN   << Spooler not active but entry is.     >> <<07438>>24060000
                                                               <<07438>>24065000
  COMMENT -- Barring a corrupted XDD, this strange state is a- <<07438>>24070000
chieved only while STREAMing an input file.  While the file is <<07438>>24075000
being created, its subentry is ACTIVE even though there is  no <<07438>>24080000
corresponding  spool device.  We have been asked to delete it, <<07438>>24085000
which is impossible because the input streamer  has  the  file <<07438>>24090000
opened  exclusively  and  can  only be interrupted by pressing <<07438>>24095000
BREAK (in a session).                                          <<07438>>24100000
  One more remote possibility -- the MRJE subsystem has  hooks <<07438>>24105000
into  this  code  and  may  be playing games with ACTIVE spool <<07438>>24110000
files for which no spooler exists.  If so, let them  clean  up <<07438>>24115000
their  act and call us again when the file is READY.           <<07438>>24120000
  The test below is to separate out the STREAM possibility and <<07438>>24125000
generate a somewhat misleading error message if that is  found <<07438>>24130000
to  be  true.  This is because the message mentions "JOB", and <<07438>>24135000
the file in question may be a :DATA file.  Oh well...          <<07438>>24140000
;                                                              <<07438>>24145000
            IF DEV = INTEGER (LDT'STREAMS'LDEV) THEN           <<07438>>24150000
               CIERR (-JOBBEINTRO);                            <<07438>>24155000
            END;    << Spooler not active but entry is.     >> <<07438>>24160000
         DELETEDEVFILE := WRONG'STATE;                         <<07438>>24165000
         END;    << Had a problem waking the spooler.       >> <<07438>>24170000
      END     << This is only other acceptable state.       >> <<07438>>24175000
   ELSE                                                        <<07438>>24180000
      BEGIN   << READY $STDIN, or OPEN or LOCKED.           >> <<07438>>24185000
      RELSIR (XDD'SIR, SAVE'XDD'SIR);                          <<07438>>24190000
      IF XDDSB'FILE'NAME = "$STDIN" THEN                       <<07438>>24195000
         DELETEDEVFILE := CAN'T'DELETE'STDIN                   <<07438>>24200000
      ELSE                                                     <<07438>>24205000
         DELETEDEVFILE := WRONG'STATE;                         <<07438>>24210000
      END     << READY $STDIN, or OPEN or LOCKED.           >> <<07438>>24215000
ELSE                                                           <<07438>>24220000
   BEGIN   << Couldn't find DFID.                           >> <<07438>>24225000
   RELSIR (XDD'SIR, SAVE'XDD'SIR);                             <<07438>>24230000
   DELETEDEVFILE := NO'MATCH;                                  <<07438>>24235000
   END;    << Couldn't find DFID.                           >> <<07438>>24240000
IF DST'AT'ENTRY <> -1 THEN EXCHANGEDB (DST'AT'ENTRY);          <<07438>>24245000
END;   << of DELETEDEVFILE.                                 >> <<07438>>24250000
                                                                        24255000
                                                                        24260000
LOGICAL PROCEDURE CONSDELETE (PARMSTRING);                              24265000
   BYTE ARRAY PARMSTRING;                                               24270000
   OPTION PRIVILEGED,UNCALLABLE;                               <<00179>>24275000
BEGIN                                                                   24280000
   BYTE POINTER      PP;                                                24285000
   INTEGER           PLEN;                                              24290000
                                                                        24295000
<< >>                                                                   24300000
   CONSDELETE := FALSE;                                                 24305000
   SCAN PARMSTRING WHILE %6440, 1;                                      24310000
   IF  NOCARRY  AND  (BPS0 = "#")  THEN                                 24315000
      BEGIN                                                             24320000
      @PP := S0;                                                        24325000
      SCAN * UNTIL %6440, 1;                                            24330000
      IF NOCARRY THEN                                                   24335000
         BEGIN                                                          24340000
         SCAN BPS0 WHILE %6440;                                         24345000
         IF NOCARRY THEN RETURN;                                        24350000
         END;                                                           24355000
      IF (PLEN := TOS -@PP) > 2 THEN                                    24360000
         BEGIN                                                          24365000
         TOS := BINARY (PP(2), PLEN-2);                                 24370000
         IF = AND (S0 > 0) THEN                                         24375000
            BEGIN                                                       24380000
            MOVE PP(1) := PP(1) WHILE AS;                      <<00.06>>24385000
            IF PP(1) <> "I" THEN                                        24390000
               IF PP(1) = "O" THEN TOS.(0:1) := 1                       24395000
               ELSE RETURN;                                             24400000
            CONSDELETE := (DELETEDEVFILE (S0, FALSE) = 0);              24405000
            END;                                                        24410000
         END;                                                           24415000
      END;                                                              24420000
   END;    <<CONSDELETE>>                                               24425000
                                                               <<01.02>>24430000
$PAGE "MRJE ROUTINES"                                          <<00858>>24435000
COMMENT This procdure is called to alter the attributes of a   <<01894>>24440000
        ready or opened output spool file. Changes may only    <<01894>>24445000
        be made to:   a) Priority,  b) Device, or  c) Copies.  <<01894>>24450000
        Supplying the approriate parameter dictates a change.  <<01894>>24455000
        Possible returns are:                                  <<01894>>24460000
                                                               <<01894>>24465000
         0  No errors  (also cce).                             <<01894>>24470000
        -1  Device file doesn't exist  (ccl).                  <<01894>>24475000
        -2  Device file ID not specified or invalid (ccl).     <<01894>>24480000
        >0  File active.   (0:8)=pri      (ccg).               <<06744>>24485000
                                                               <<01894>>24490000
        It is assumed that all parameters passed have been     <<01894>>24495000
        tested and are valid. No attemp is made to change the  <<01894>>24500000
        state of the spool file. If 'device' is specified, it  <<01894>>24505000
        should be supplied in the same format as the DEVINFO   <<01894>>24510000
        return from 'getdevinfo' ie. negative class;           <<01894>>24515000
                                                               <<01894>>24520000
INTEGER PROCEDURE alteroutputfile ( dfid, pri, dev, copies );  <<01894>>24525000
  VALUE dfid, pri, dev, copies;                                <<01894>>24530000
  INTEGER dfid, pri, dev, copies;                              <<01894>>24535000
  OPTION VARIABLE, PRIVILEGED, UNCALLABLE;                     <<01894>>24540000
  BEGIN                                                        <<01894>>24545000
                                                               <<01894>>24550000
   EQUATE ccg            = 0,                                  <<06744>>24555000
          ccl            = 1,                                  <<01894>>24560000
          cce            = 2;                                  <<01894>>24565000
                                                               <<01894>>24570000
DEFINE cc = status.(6:2)#;                                     <<01894>>24575000
                                                               <<01894>>24580000
     LOGICAL bit'mask = q-4,     << Option variable mask >>    <<01894>>24585000
             status   = q-1;     << Status register >>         <<01894>>24590000
                                                               <<01894>>24595000
     INTEGER saveldt,            << for getsir call >>         <<01894>>24600000
             savelpdt,                                         <<01894>>24605000
             savexdd,                                          <<01894>>24610000
             device'class,                                     <<06744>>24615000
             roosterparm := 0,                                 <<07438>>24620000
             xddep;              << entry pointer in odd >>    <<01894>>24625000
                                                               <<06744>>24630000
     INTEGER POINTER xddp = xddep;                             <<06744>>24635000
                                                               <<01894>>24640000
     LOGICAL relink;                                           <<01894>>24645000
                                                               <<01894>>24650000
     LOGICAL ARRAY xdd'subentry(0:size'of'xdd'subentry);       <<06744>>24655000
                                                               <<01894>>24660000
LOGICAL POINTER         xdd'head;                              <<06744>>24665000
                                                               <<06744>>24670000
     SUBROUTINE def'movefromdseg;                              <<01894>>24675000
                                                               <<01894>>24680000
     SUBROUTINE def'movetodseg;                                <<01894>>24685000
                                                               <<01894>>24690000
                                                               <<01894>>24695000
                                                               <<01894>>24700000
                                                               <<01894>>24705000
     alteroutputfile := 0;        << Assume successful >>      <<01894>>24710000
     cc := cce;                                                <<01894>>24715000
     roosterparm := 0;                                         <<01894>>24720000
     relink := FALSE;                                          <<01894>>24725000
                                                               <<01894>>24730000
     IF (NOT bit'mask.(12:1)) OR  << File not supplied >>      <<01894>>24735000
        (dfid >= 0) THEN          << Invalid fileid >>         <<01894>>24740000
     BEGIN                                                     <<01894>>24745000
        alteroutputfile := -2;    << dfid not supplied >>      <<01894>>24750000
        cc := ccl;                                             <<01894>>24755000
        RETURN;                                                <<01894>>24760000
     END;                                                      <<01894>>24765000
                                                               <<01894>>24770000
     saveldt  := getsir ( ldt'sir );                           <<06744>>24775000
     savelpdt := getsir ( lpdt'sir );                          <<06744>>24780000
     savexdd  := getsir ( odd'sir );                           <<06744>>24785000
                                                               <<01894>>24790000
     IF NOT sfindodd ( dfid, xddep ) then                      <<06744>>24795000
     BEGIN                                                     <<01894>>24800000
        alteroutputfile := -1;    << No such file >>           <<01894>>24805000
        cc := ccl;                                             <<01894>>24810000
     END ELSE                                                  <<01894>>24815000
     BEGIN                                                     <<01894>>24820000
        xddep.(0:1) := 0;        << Reset high bit >>          <<06744>>24825000
        movefromdseg ( xdd'subentry, odd'dst, xddep,           <<06744>>24830000
                       size'of'xdd'subentry );                 <<06744>>24835000
        IF xdds'spool'state = xdds'active then                 <<06744>>24840000
        BEGIN                                                  <<01894>>24845000
           alteroutputfile := xdds'output'priority &lsl(8);    <<06744>>24850000
                                                               <<06744>>24855000
           cc := ccg;                                          <<01894>>24860000
        END ELSE                                               <<01894>>24865000
        BEGIN                                                  <<01894>>24870000
           IF xdds'spoofle'vt'index = 0 then                   <<06916>>24875000
           BEGIN                                               <<01894>>24880000
              alteroutputfile := -1;  << No file >>            <<01894>>24885000
              cc := ccl;                                       <<01894>>24890000
           END ELSE                                            <<01894>>24895000
           BEGIN            << All tests passed >>             <<01894>>24900000
                                                               <<01894>>24905000
              IF bit'mask.(13:1) THEN                          <<01894>>24910000
              BEGIN                                            <<01894>>24915000
                 xdds'output'priority := pri;                  <<06744>>24920000
                 relink := TRUE;                               <<01894>>24925000
              END;                                             <<01894>>24930000
                                                               <<01894>>24935000
              IF bit'mask.(14:1) THEN                          <<01894>>24940000
              BEGIN                                            <<01894>>24945000
                 IF dev < 0 THEN   << class >>                 <<01894>>24950000
                 BEGIN                                         <<01894>>24955000
                    xdds'device := -dev;                       <<06744>>24960000
                    xdds'class := true;                        <<06744>>24965000
                 END ELSE                                      <<01894>>24970000
                 BEGIN                                         <<01894>>24975000
                    xdds'device := dev;                        <<06744>>24980000
                    xdds'class := false;                       <<06744>>24985000
                 END;                                          <<01894>>24990000
                 relink := TRUE;                               <<01894>>24995000
              END;                                             <<01894>>25000000
                                                               <<01894>>25005000
              IF bit'mask.(15:1) THEN                          <<01894>>25010000
                 odds'number'copies := copies;                 <<06744>>25015000
                                                               <<01894>>25020000
              movetodseg (odd'dst, xddep, xdd'subentry,        <<06744>>25025000
                          size'of'xdd'subentry);               <<06744>>25030000
              IF relink THEN                                   <<01894>>25035000
              BEGIN                                            <<01894>>25040000
                 if xdds'class then device'class:= -xdds'device<<06744>>25045000
                 else                                          <<06744>>25050000
                    device'class := xdds'device;               <<06744>>25055000
                 srelinkodd ( xddp, device'class);             <<06744>>25060000
                 roosterparm := device'class;                  <<06744>>25065000
              END;   << of relink >>                           <<01894>>25070000
              IF roosterparm <> 0 THEN srooster(roosterparm);  <<01894>>25075000
           END;                                                <<01894>>25080000
        END;                                                   <<01894>>25085000
     END;                                                      <<01894>>25090000
                                                               <<01894>>25095000
     relsir ( odd'sir, savexdd );                              <<06744>>25100000
     relsir ( lpdt'sir, savelpdt );                            <<06744>>25105000
     relsir ( ldt'sir, saveldt );                              <<06744>>25110000
                                                               <<01894>>25115000
  END;      << Of alteroutputfile >>                           <<01894>>25120000
                                                               <<01.02>>25125000
<<   SPECIAL INTERFACE FOR MRJE TO ALLOW PROGRAMMATIC   >>     <<01.02>>25130000
<<   DELETE OF DEVICEFILES                              >>     <<01.02>>25135000
INTEGER PROCEDURE MRJEDELETE (DFID);                           <<01.02>>25140000
   VALUE   DFID;                                               <<01.02>>25145000
   INTEGER DFID;                                               <<01.02>>25150000
   OPTION PRIVILEGED,UNCALLABLE;                               <<01.02>>25155000
   BEGIN                                                       <<01.02>>25160000
   INTEGER ERROR;                                              <<01.02>>25165000
   << >>                                                       <<01.02>>25170000
   ERROR := DELETEDEVFILE(DFID,FALSE);                         <<01.02>>25175000
   IF ERROR <> 0 THEN                                          <<01.02>>25180000
      IF (ERROR = 3) OR (ERROR = 4) THEN ERROR := 2            <<04694>>25185000
                   ELSE ERROR := 1;                            <<01.02>>25190000
   MRJEDELETE := ERROR;                                        <<01.02>>25195000
   END;    << MRJEDELETE >>                                    <<01.02>>25200000
$CONTROL SEGMENT=SPOOLCOMS1                                    <<00858>>25205000
<< SPECIAL INTERFACE FOR MRJE TO ALLOW>>                       <<00858>>25210000
<< PROGRAMMATIC CHANGING OF USERNAME AND>>                     <<00858>>25215000
<< ACCOUNT NAME IN OUTPUT DEVICE DIRECTORY>>                   <<00858>>25220000
                                                               <<00858>>25225000
INTEGER PROCEDURE CHANGEODD(DFID,NEWUSER,NEWACCT);             <<00858>>25230000
   VALUE DFID;                                                 <<00858>>25235000
   INTEGER DFID;                                               <<00858>>25240000
   BYTE ARRAY NEWUSER,NEWACCT;                                 <<00858>>25245000
   OPTION UNCALLABLE,PRIVILEGED;                               <<00858>>25250000
                                                               <<00858>>25255000
   BEGIN                                                       <<00858>>25260000
                                                               <<00858>>25265000
   INTEGER ERROR, DFILEID, OLDSIR, XDDEP;                      <<06744>>25270000
   LOGICAL ARRAY XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY);         <<06744>>25275000
   BYTE ARRAY USER(*) = XDDS'USER'NAME;                        <<06744>>25280000
   BYTE ARRAY ACCT(*) = XDDS'ACCOUNT'NAME;                     <<06744>>25285000
                                                               <<00858>>25290000
   SUBROUTINE DEF'MOVEFROMDSEG;                                <<00858>>25295000
                                                               <<00858>>25300000
   SUBROUTINE DEF'MOVETODSEG;                                  <<00858>>25305000
                                                               <<00858>>25310000
   DFILEID := LOGICAL(DFID) LOR %100000;                       <<00858>>25315000
   OLDSIR := GETSIR(ODD'SIR);                                  <<06744>>25320000
   IF NOT SFINDODD(DFILEID,XDDEP) THEN                         <<00858>>25325000
      ERROR := 1                                               <<00858>>25330000
   ELSE                                                        <<00858>>25335000
   BEGIN                                                       <<00858>>25340000
      XDDEP.(0:1) := 0;   << Turn off bit set by SFINDODD.  >> <<07438>>25345000
      MOVEFROMDSEG(XDD'SUBENTRY, ODD'DST, XDDEP,               <<06744>>25350000
                   SIZE'OF'XDD'SUBENTRY);                      <<06744>>25355000
      USER := " ";                                             <<00858>>25360000
      MOVE USER(1) := USER, (15);                              <<00858>>25365000
      MOVE USER := NEWUSER WHILE AN;                           <<00858>>25370000
      MOVE ACCT := NEWACCT WHILE AN;                           <<00858>>25375000
      MOVETODSEG(ODD'DST, XDDEP, XDD'SUBENTRY,                 <<06744>>25380000
                 SIZE'OF'XDD'SUBENTRY);                        <<06744>>25385000
      ERROR := 0;                                              <<00858>>25390000
   END;                                                        <<00858>>25395000
   RELSIR(ODD'SIR,OLDSIR);                                     <<06744>>25400000
   CHANGEODD := ERROR;                                         <<00858>>25405000
END; << CHANGEODD>>                                            <<00858>>25410000
$PAGE "***   INPUT STREAMER   ***"                                      25415000
$CONTROL SEGMENT= SPOOLCOMS1                                            25420000
PROCEDURE STREAMJNUM;                                                   25425000
OPTION UNCALLABLE;                                                      25430000
   BEGIN <<STREAMJNUM>>                                                 25435000
   INTEGER CONTROL           := %320  ;                                 25440000
   ARRAY   LINE(0:4) ;                                                  25445000
   BYTE ARRAY BLINE(*)       = LINE  ;                                  25450000
      << >>                                                             25455000
   IF PROMPTING OR                                                      25460000
      LISTSIZE - 5 < (JLISTED := JLISTED + 5) THEN                      25465000
      BEGIN <<END OF THE LINE>>                                         25470000
      CONTROL := JLISTED := 0;                                          25475000
      END <<END OF THE LINE>>;                                          25480000
   LINE := "  ";                                                        25485000
   MOVE LINE(1) := LINE,(4);                                            25490000
   BLINE(1) := "#";                                                     25495000
   TOS := %112;                                                         25500000
   TOS := 0;                                                            25505000
   IF @JMATP > 0 THEN                                                   25510000
      BEGIN <<JOB>>                                                     25515000
      TOS := JOBNUMBER.(2:14);                                          25520000
      END <<JOB>>                                                       25525000
   ELSE                                                                 25530000
      BEGIN <<DATA>>                                                    25535000
      ASSEMBLE(DECB);                                                   25540000
      TOS := DEVFILEID;                                                 25545000
      END <<DATA>>;                                                     25550000
   ASCII(*,10,BLINE(3));                                                25555000
   BLINE(2) := TOS;                                                     25560000
   PRINT(LINE,5,CONTROL);                                               25565000
   END <<STREAMJNUM>>;                                                  25570000
PROCEDURE CXSTREAM(PARMSP,ERRNUM,PARMNUM);                     <<U.RAO>>25575000
BYTE ARRAY PARMSP;                                             <<U.RAO>>25580000
INTEGER ERRNUM,PARMNUM;                                        <<U.RAO>>25585000
OPTION PRIVILEGED,UNCALLABLE;                                  <<U.RAO>>25590000
   BEGIN <<CXSTREAM>>                                          <<U.RAO>>25595000
   EQUATE  MAXPARMS          = 4         ,                     <<U.RAO>>25600000
           SEMI'EX           = 2         ,                     <<01514>>25605000
           DFLT'ACC          = 0         ,                     <<01514>>25610000
           EX'ACC            = 6         ,                     <<01514>>25615000
           FOPOMITTED        = %2047     ,                     <<U.RAO>>25620000
           FOPSUPPLIED       = %2007     ;                     <<U.RAO>>25625000
   DEFINE  ACCESS'BITS       = (12:4)#   ,                     <<01514>>25630000
           EXCLU'BITS        = (8:2) #   ;                     <<01514>>25635000
   LOGICAL FOPTIONS     := FOPOMITTED ,                        <<U.RAO>>25640000
           AOPTIONS,                                           <<01514>>25645000
           OPENOK            := FALSE,                         <<01514>>25650000
           PROMPT            := FALSE ,                        <<U.RAO>>25655000
           DUMMY                      ,                        <<U.RAO>>25660000
           LERRPTR           := 0     ,                        <<U.RAO>>25665000
           INLIST                     ,                        <<06744>>25670000
           OUTLIST                    ,                        <<06744>>25675000
           STREAMS'LDEV               ,                        <<07438>>25680000
           WASCRITICAL                ;                        <<U.RAO>>25685000
   INTEGER FILENUMBER        := 0     ,                        <<U.RAO>>25690000
           NUMPARMS                   ,                        <<U.RAO>>25695000
           OLDZ'DB                    ;                        <<U.RAO>>25700000
   INTEGER LDT'INDEX         := 0     ,                        <<07438>>25705000
           LPDT'INDEX                 ;                        <<06744>>25710000
   LOGICAL ARRAY SCHEDINFO(0:2);  << Date (0) & time (1,2). >> <<S8948>>25715000
   LOGICAL ARRAY LDT (0:SIZE'OF'LDT'ENTRY-1);                  <<07438>>25720000
   INTEGER POINTER PCB=SYSPCBINDEX;                            <<06744>>25725000
   INTEGER PCBPT;                                              <<06744>>25730000
   ARRAY QARRAY(*) = Q+0;   <<for access to pcbglob>>          <<06916>>25735000
   INTEGER PCBGLOBLOC;                                         <<06916>>25740000
   ARRAY   LOCALGLOBALS(0:GLOBSIZE)   ;                        <<04382>>25745000
   << PARSE DECLARATIONS >>                                    <<U.RAO>>25750000
   DOUBLE ARRAY PARMS(0:MAXPARMS-1) = Q  ;                     <<U.RAO>>25755000
   BYTE POINTER PP;                                            <<S8948>>25760000
   INTEGER                                                     <<S8948>>25765000
      PLEN,                                                    <<S8948>>25770000
      NEXTDELIM;                                               <<S8948>>25775000
   DOUBLE                                                      <<S8948>>25780000
      DELIMS := [8/",",8/";",8/%15,8/0]D;                      <<S8948>>25785000
   EQUATE                                                      <<S8948>>25790000
      COMMA = 0,                                               <<S8948>>25795000
      SEMI = 1,                                                <<S8948>>25800000
      CR = 2;                                                  <<S8948>>25805000
   BYTE ARRAY                                                  <<S8948>>25810000
      DXL(*) = DELIMS;                                         <<S8948>>25815000
   BYTE POINTER FILENAME = PARMS;                              <<S8948>>25820000
   << FILE SPECIFICATIONS >>                                   <<U.RAO>>25825000
   BYTE    COLON             := "!"      ;                     <<U.RAO>>25830000
   BYTE POINTER ERRPTR = LERRPTR;  <<RTN VALUE FROM CHECKFILENA<<U.RAO>>25835000
   BYTE POINTER FORMALDES := @DXL(CR);   << The CR >>          <<S8948>>25840000
                                                               <<F9095>>25845000
<< FFILEINFO declarations:                                  >> <<F9095>>25850000
<<    Item numbers:                                         >> <<F9095>>25855000
                                                               <<F9095>>25860000
   EQUATE                                                      <<F9095>>25865000
      FFNUM'FOPTIONS = 2,                                      <<F9095>>25870000
      FFNUM'LDNUM    = 6,                                      <<F9095>>25875000
      FFNUM'RECSIZE  = 4;                                      <<F9095>>25880000
                                                               <<F9095>>25885000
<<    Item values -- byte array equiv of existing variables >> <<F9095>>25890000
                                                               <<F9095>>25895000
   BYTE ARRAY                                                  <<F9095>>25900000
      FF'DEVICE(*)   = DEVICE,                                 <<F9095>>25905000
      FF'FOPTIONS(*) = FOPTIONS,                               <<F9095>>25910000
      FF'RECL(*)     = RECL;                                   <<F9095>>25915000
                                                               <<07438>>25920000
   SUBROUTINE DEF'MOVEFROMDSEG;                                <<07438>>25925000
                                                               <<00534>>25930000
   SUBROUTINE CLEANUP;                                         <<00534>>25935000
      << RESETS THINGS TO THE WAY THEY WERE >>                 <<00534>>25940000
      BEGIN                                                    <<00534>>25945000
      MOVE ARRDB0 := LOCALGLOBALS,(GLOBSIZE);                  <<00534>>25950000
      RESETCRITICAL(WASCRITICAL);                              <<00534>>25955000
      FCLOSE(FILENUMBER,-1,0);                                 <<00534>>25960000
      END;                                                     <<00534>>25965000
                                                               <<00534>>25970000
   SUBROUTINE GETNEXT;                                         <<S8948>>25975000
      << Extracts the next parameter from the PARMS array >>   <<S8948>>25980000
      << and decomposes the MYCOMMAND entry.              >>   <<S8948>>25985000
   BEGIN                                                       <<S8948>>25990000
   TOS := PARMS(PARMNUM);       << Get the next entry >>       <<S8948>>25995000
   NEXTDELIM := S0.DELIMITER;   << Trailing delim >>           <<S8948>>26000000
   PLEN := TOS&LSR(8);          << Parameter length >>         <<S8948>>26005000
   @PP := TOS;                  << Pointer to the PARM >>      <<S8948>>26010000
   PARMNUM := PARMNUM + 1;                                     <<S8948>>26015000
   END;   << of GETNEXT >>                                     <<S8948>>26020000
                                                               <<S8948>>26025000
   << >>                                                       <<U.RAO>>26030000
   PUSH(STATUS);                                               <<U.RAO>>26035000
   TOS.(2:1) := 0;                                             <<U.RAO>>26040000
   SET(STATUS);                                                <<U.RAO>>26045000
   ERRNUM := 0;                                                <<U.RAO>>26050000
   PARMNUM := 0;                                               <<U.RAO>>26055000
   SCHEDINFO := 0;                                             <<S8948>>26060000
   MOVE SCHEDINFO(1) := SCHEDINFO, (2);                        <<S8948>>26065000
   PXGLOBAL;   <<init pointers>>                               <<06916>>26070000
   INLIST := PXG'INPUTLDEV;                                    <<07438>>26075000
   OUTLIST := PXG'OUTPUTLDEV;                                  <<07438>>26080000
   MOVEFROMDSEG (LDT, LDT'DST, 0, SIZE'OF'LDT'ENTRY);          <<07438>>26085000
   STREAMS'LDEV := LDT'STREAMS'LDEV;                           <<07438>>26090000
   MOVEFROMDSEG (LDT, LDT'DST, OUTLIST*SIZE'OF'LDT'ENTRY,      <<07438>>26095000
                 SIZE'OF'LDT'ENTRY);                           <<07438>>26100000
   IF STREAMS'LDEV = 0 THEN                                    <<07438>>26105000
      CIERR(ERRNUM := STRMNOTENABLED)    <<FACILITY OFF>>      <<U.RAO>>26110000
   ELSE                                                        <<U.RAO>>26115000
      BEGIN <<STREAMING>>                                      <<U.RAO>>26120000
      MYCOMMAND(PARMSP,DXL,MAXPARMS,NUMPARMS,PARMS);           <<U.RAO>>26125000
      IF NUMPARMS > 0 THEN                                     <<U.RAO>>26130000
         BEGIN <<SOME PARM(S)>>                                <<U.RAO>>26135000
         GETNEXT;   << Get the first parameter >>              <<S8948>>26140000
         IF PLEN <> 0 THEN      << File name present >>        <<S8948>>26145000
            BEGIN   <<CHECK NAME VALIDITY>>                    <<U.RAO>>26150000
            ERRNUM := CHECKFILENAME'(PARMS&LSR(8),DUMMY,       <<U.RAO>>26155000
                         DUMMY, LERRPTR);                      <<U.RAO>>26160000
            IF < THEN   <<SYNTAX ERROR IN FILE NAME>>          <<U.RAO>>26165000
               CIERR(ERRNUM, ERRPTR)                           <<U.RAO>>26170000
            ELSE IF > AND ERRNUM <> 0 THEN  <<SYS DEF FILE>>   <<U.RAO>>26175000
               IF ERRNUM <> 3 THEN  <<NOT $OLDPASS>>           <<U.RAO>>26180000
                  CIERR(ERRNUM := STRMNOSYSDEF, FILENAME)      <<U.RAO>>26185000
               ELSE   <<IS $OLDPASS, LEGAL>>                   <<U.RAO>>26190000
                  ERRNUM := 0;  <<CLEANUP>>                    <<U.RAO>>26195000
            @FORMALDES := @FILENAME;                           <<U.RAO>>26200000
            FOPTIONS := FOPSUPPLIED;  <<FILE SUPPLIED>>        <<U.RAO>>26205000
            IF ERRNUM <> 0 THEN RETURN;                        <<S8948>>26210000
            END;                                               <<U.RAO>>26215000
         IF NEXTDELIM = COMMA THEN                             <<S8948>>26220000
            BEGIN      << Try to get the pseudo-colon >>       <<S8948>>26225000
            GETNEXT;                                           <<S8948>>26230000
            IF PLEN = 1 THEN                                   <<S8948>>26235000
               COLON := PP    << Pick it up >>                 <<S8948>>26240000
            ELSE IF PLEN > 1 THEN   << Invalid colon >>        <<S8948>>26245000
               ERRNUM := STRMINVLDCOLON                        <<S8948>>26250000
            ELSE IF NEXTDELIM <> CR THEN                       <<S8948>>26255000
               BEGIN      << Possible "," or ";" >>            <<S8948>>26260000
               IF NEXTDELIM = COMMA THEN                       <<S8948>>26265000
                  BEGIN                                        <<S8948>>26270000
                  COLON := PP;                                 <<S8948>>26275000
                  GETNEXT;                                     <<S8948>>26280000
               << "STREAM ,,<timeparms>" is not legal >>       <<S8948>>26285000
                  IF PLEN <> 0 THEN ERRNUM := STRMXPCTSEMI;    <<S8948>>26290000
                  END                                          <<S8948>>26295000
               ELSE                                            <<S8948>>26300000
                  BEGIN   << ";" >>                            <<S8948>>26305000
                  COLON := PP;                                 <<S8948>>26310000
                  GETNEXT;                                     <<S8948>>26315000
               << If "STREAM ,;<timeparms>", then restore ! >> <<S8948>>26320000
               << as job character & backspace parser.      >> <<S8948>>26325000
                  IF PLEN <> 0 THEN                            <<S8948>>26330000
                     BEGIN                                     <<S8948>>26335000
                     COLON := "!";                             <<S8948>>26340000
                     PARMNUM := PARMNUM - 2;                   <<S8948>>26345000
                     GETNEXT;                                  <<S8948>>26350000
                     END;                                      <<S8948>>26355000
                  END;    << ";" >>                            <<S8948>>26360000
               END;                                            <<S8948>>26365000
            END;   << of pseudo-colon handling >>              <<S8948>>26370000
         IF ERRNUM <> 0 THEN                                   <<S8948>>26375000
            CIERR( ERRNUM, PP )                                <<S8948>>26380000
         ELSE                                                  <<S8948>>26385000
            IF NEXTDELIM = SEMI THEN                           <<S8948>>26390000
               BEGIN                                           <<S8948>>26395000
               GETNEXT;                                        <<S8948>>26400000
               TIMEPARMS( PP, SCHEDINFO, ERRNUM, TRUE );       <<S8948>>26405000
               END                                             <<S8948>>26410000
            ELSE IF NEXTDELIM <> CR THEN                       <<S8948>>26415000
               BEGIN                                           <<S8948>>26420000
               GETNEXT;                                        <<S8948>>26425000
               CIERR( ERRNUM := STRMXPCTSEMI, PP );            <<S8948>>26430000
               END;                                            <<S8948>>26435000
         IF ERRNUM > 0 THEN RETURN;                            <<S8948>>26440000
         END <<SOME PARM(S)>>;                                 <<U.RAO>>26445000
                                                               <<01514>>26450000
   << THERE ARE TWO CHANCES TO OPEN THE STREAM FILE.       >>  <<01514>>26455000
   << FIRST:  THE OLD WAY--WITH READ ACCESS ONLY.  IF THAT >>  <<01514>>26460000
   << FAILS, THEN THE SECOND WAY--WITH EXECUTE ACCESS, IS  >>  <<01514>>26465000
   << TRIED.  BOTH ATTEMPTS ALLOW SEMI-EXCLUSIVE ACCESS BY >>  <<01514>>26470000
   << OTHERS.                                              >>  <<01514>>26475000
      AOPTIONS := 0;                                           <<01514>>26480000
      AOPTIONS.EXCLU'BITS := SEMI'EX;                          <<01514>>26485000
      AOPTIONS.ACCESS'BITS := DFLT'ACC;                        <<01514>>26490000
      FILENUMBER := FOPEN( FORMALDES, FOPTIONS, AOPTIONS );    <<01514>>26495000
      IF = THEN OPENOK := TRUE                                 <<01514>>26500000
      ELSE                                                     <<01514>>26505000
      BEGIN                                                    <<01514>>26510000
         AOPTIONS.ACCESS'BITS := EX'ACC;                       <<01514>>26515000
         FILENUMBER :=                                         <<01514>>26520000
            FOPEN( FORMALDES, FOPTIONS, AOPTIONS );            <<01514>>26525000
         IF = THEN OPENOK := TRUE;                             <<01514>>26530000
      END;                                                     <<01514>>26535000
      IF NOT OPENOK THEN                                       <<01514>>26540000
         BEGIN <<CAN'T OPEN STREAM FILE>>                      <<00534>>26545000
         FERROR'(FILENUMBER,PARMNUM);                          <<00534>>26550000
         CIERR(ERRNUM:=STRMFILEOPENERR);                       <<00534>>26555000
         END                                                   <<00534>>26560000
      ELSE                                                     <<U.RAO>>26565000
         BEGIN <<SUCCESSFUL FOPEN>>                            <<U.RAO>>26570000
                                                               <<03505>>26575000
         << Make sure there will be enough stack space >>      <<03505>>26580000
                                                               <<03505>>26585000
         TOS := %3600;                                         <<03505>>26590000
         ASSEMBLE (ADDS 0);                                    <<03505>>26595000
         TOS := %3600;                                         <<03505>>26600000
         ASSEMBLE (SUBS 0);                                    <<03505>>26605000
                                                               <<03505>>26610000
         WASCRITICAL := SETCRITICAL;                           <<U.RAO>>26615000
         MOVE LOCALGLOBALS := ARRDB0,(GLOBSIZE);               <<U.RAO>>26620000
         DB0 := 0;                                             <<U.RAO>>26625000
         MOVE ARRDB1 := ARRDB0,(GLOBSIZE-1);                   <<U.RAO>>26630000
         SPOOLER := FALSE;                                     <<U.RAO>>26635000
         STREAMDEV := STREAMS'LDEV;                            <<07438>>26640000
         LISTTYPE := LDT'DEVICE'TYPE;                          <<07438>>26645000
         LISTSIZE := LDT'RECORD'WIDTH;                         <<07438>>26650000
         PSEUDOCOLON := COLON;                                 <<U.RAO>>26655000
         DEVICEFILE := FILENUMBER;                             <<U.RAO>>26660000
         JLISTED := 0;                                         <<U.RAO>>26665000
         FFILEINFO (DEVICEFILE, FFNUM'FOPTIONS, FF'FOPTIONS,   <<F9095>>26670000
                                FFNUM'RECSIZE,  FF'RECL,       <<F9095>>26675000
                                FFNUM'LDNUM,    FF'DEVICE);    <<F9095>>26680000
         IF NOT FOPTIONS&LSR(2) THEN                           <<U.RAO>>26685000
            BEGIN <<FILE ISN'T ASCII>>                         <<U.RAO>>26690000
            CLEANUP;                                           <<00534>>26695000
            CIERR(ERRNUM:=FILENOTASCII);                       <<00534>>26700000
            END <<FILE ISN'T ASCII>>                           <<U.RAO>>26705000
         ELSE                                                  <<U.RAO>>26710000
            BEGIN <<ASCII file>>                               <<04912>>26715000
            LPDT'INDEX:=DEVICE*SIZE'OF'LPDT'ENTRY;             <<06744>>26720000
            IF LPDT'INTERACTIVE THEN                           <<06744>>26725000
               BEGIN <<INTERACTIVE>>                           <<U.RAO>>26730000
               MOVEFROMDSEG (LDT, LDT'DST, DEVICE*             <<07438>>26735000
                  SIZE'OF'LDT'ENTRY, SIZE'OF'LDT'ENTRY);       <<07438>>26740000
               IF NOT LDT'CLASS'INDEX AND                      <<06744>>26745000
                 LDT'DFLT'OUT'DEV = OUTLIST                    <<06744>>26750000
                  THEN PROMPT := TRUE;                         <<U.RAO>>26755000
               END <<INTERACTIVE>>;                            <<U.RAO>>26760000
            PROMPTING := PROMPT;                               <<U.RAO>>26765000
            FUTURE'DATE := SCHEDINFO;                          <<S8948>>26770000
            MOVE FUTURE'TIME := SCHEDINFO(1), (2);             <<S8948>>26775000
            RECL := ((-RECL)+1)&LSR(1);                        <<U.RAO>>26780000
            DEVICERECL := RECL;                                <<U.RAO>>26785000
            PUSH(Z);                                           <<U.RAO>>26790000
            OLDZ'DB := TOS;                                    <<U.RAO>>26795000
            TOS := 0;                                          <<U.RAO>>26800000
            PUSH(S);                                           <<U.RAO>>26805000
            TOS := TOS + LOCSIZE;                              <<U.RAO>>26810000
            ZSIZE(*);                                          <<U.RAO>>26815000
            IF <> THEN                                         <<00534>>26820000
               BEGIN                                           <<00534>>26825000
               ZSIZE(OLDZ'DB);                                 <<00534>>26830000
               CLEANUP;                                        <<00534>>26835000
               CIERR(ERRNUM:=NOSUCHSTACK);                     <<00534>>26840000
               END                                             <<00534>>26845000
            ELSE                                               <<U.RAO>>26850000
               BEGIN <<ROOM ENUF>>                             <<U.RAO>>26855000
               SPOOLREQUEST := KEEPSPOOLING;                   <<U.RAO>>26860000
               FILEREQUEST := FINISHFILE;                      <<U.RAO>>26865000
            << NOW PROCESS THE STREAM FILE. ALL ERRORS WILL>>  <<00534>>26870000
            << BE PRINTED IN SPOOLINTO. ERRNUM AND PARMNUM >>  <<00534>>26875000
            << ARE FOR THE COMMAND INTRINSIC AND REFLECT   >>  <<00534>>26880000
            << THE LAST ERROR TO OCCUR IN PROCESSING.      >>  <<00534>>26885000
                                                               <<00534>>26890000
               SPOOLINTO;                                      <<00534>>26895000
                                                               <<00534>>26900000
               TOS := CIERRNUM;  << SAVE ERR # AND PARM # >>   <<00534>>26905000
               TOS := CIPARMNUM; << FROM GLOBAL AREA.     >>   <<00534>>26910000
               ZSIZE(OLDZ'DB);                                 <<00534>>26915000
               CLEANUP;                                        <<00534>>26920000
               PARMNUM := TOS;  << SET COMMAND INTRINSIC  >>   <<00534>>26925000
               ERRNUM := TOS;   << RETURN PARAMETERS.     >>   <<00534>>26930000
                                                               <<00751>>26935000
            << No longer critical. If an error occured in >>   <<00751>>26940000
            << SPOOLINTO then call CIERR to TERMINATE if  >>   <<00751>>26945000
            << this is a job with no previous :CONTINUE.  >>   <<00751>>26950000
               IF ERRNUM > 0 THEN CIERR;                       <<00751>>26955000
                                                               <<00534>>26960000
            << IF PROGRAMMATIC STREAM THEN RESET EOF ON   >>   <<00534>>26965000
            << $STDIN TO ALLOW FUTURE READS.              >>   <<00534>>26970000
               PCBPT := CURPRC;                                <<06744>>26975000
               IF LOGICAL(SPCBPTYPE) < 2 THEN <<PROGRAMMATIC>> <<06744>>26980000
                  FRESETEOF;                                   <<06744>>26985000
               PRINT(LOCALGLOBALS,0,0);   << CR,LF >>          <<00534>>26990000
               END <<ROOM ENUF>>;                              <<00534>>26995000
            END <<ASCII FILE>>;                                <<00534>>27000000
         END <<SUCCESSFULL FOPEN>>;                            <<00534>>27005000
      END <<STREAMING>>;                                       <<00534>>27010000
   END <<CXSTREAM>>;                                           <<00534>>27015000
$CONTROL SEGMENT=SPOOLCOMS1                                    <<01549>>27020000
$PAGE "PCHECK'xxx'ENV, PLOAD'xxx'ENV -- FORWARD DECLARATIONS"  <<06066>>27025000
logical procedure PCHECK'CIPER'ENV( Env'file'num,              <<04382>>27030000
                                    Scratch'buffer,            <<04382>>27035000
                                    Return'Status,             <<04382>>27040000
                                    Error'number   );          <<04382>>27045000
                                                               <<04382>>27050000
  integer                           Env'file'num,              <<04382>>27055000
                                    Return'Status,             <<04382>>27060000
                                    Error'number    ;          <<04382>>27065000
                                                               <<04382>>27070000
  logical array                     Scratch'buffer  ;          <<04382>>27075000
                                                               <<04382>>27080000
  OPTION PRIVILEGED, UNCALLABLE, FORWARD;                      <<06066>>27085000
                                                               <<06066>>27090000
                                                               <<06066>>27095000
                                                               <<06066>>27100000
PROCEDURE PLOAD'CIPER'ENV (OUT'FILE'NUM, ENV'FILE'NUM,         <<06066>>27105000
          SCRATCH'BUFFER, RETURN'STATUS, ERROR'NUMBER);        <<06066>>27110000
  VALUE OUT'FILE'NUM, ENV'FILE'NUM;                            <<06066>>27115000
  INTEGER OUT'FILE'NUM, ENV'FILE'NUM, RETURN'STATUS,           <<06066>>27120000
          ERROR'NUMBER;                                        <<06066>>27125000
  LOGICAL ARRAY SCRATCH'BUFFER;                                <<06066>>27130000
  OPTION PRIVILEGED, UNCALLABLE, FORWARD;                      <<06066>>27135000
                                                               <<06066>>27140000
                                                               <<06066>>27145000
                                                               <<06066>>27150000
LOGICAL PROCEDURE PCHECK'LYNXII'ENV (ENV'FILE'NUM,             <<06066>>27155000
        SCRATCH'BUFFER, RETURN'STATUS, ERROR'NUM);             <<06066>>27160000
  VALUE ENV'FILE'NUM;                                          <<06066>>27165000
  INTEGER ENV'FILE'NUM, RETURN'STATUS, ERROR'NUM;              <<06066>>27170000
  LOGICAL ARRAY SCRATCH'BUFFER;                                <<06066>>27175000
  OPTION PRIVILEGED, UNCALLABLE, FORWARD;                      <<06066>>27180000
                                                               <<06066>>27185000
                                                               <<06066>>27190000
                                                               <<06066>>27195000
PROCEDURE PLOAD'LYNXII'ENV (OUT'FILE'NUM, ENV'FILE'NUM,        <<06066>>27200000
          SCRATCH'BUFFER, RETURN'STATUS, ERROR'NUM);           <<06066>>27205000
  VALUE OUT'FILE'NUM, ENV'FILE'NUM;                            <<06066>>27210000
  INTEGER OUT'FILE'NUM, ENV'FILE'NUM, RETURN'STATUS, ERROR'NUM;<<06066>>27215000
  LOGICAL ARRAY SCRATCH'BUFFER;                                <<06066>>27220000
  OPTION PRIVILEGED, UNCALLABLE, FORWARD;                      <<06066>>27225000
$PAGE "                     PCHECKENV"                         <<01549>>27230000
procedure PCHECKENV( EnvFileName,Status,ErrNum );              <<01549>>27235000
  byte array EnvFileName;                                      <<01549>>27240000
  integer Status,ErrNum;                                       <<01549>>27245000
  OPTION PRIVILEGED, UNCALLABLE;                               <<06066>>27250000
                                                               <<01549>>27255000
comment                                                        <<01549>>27260000
  This procedure is used to check the validity of an alleged   <<01549>>27265000
environment file supplied by a user.  It opens the file, and ma<<01549>>27270000
sure that the file supplied is actually an environment file, by<<01549>>27275000
looking at the file code (which should be 1112) and the record <<01549>>27280000
size (which should be 512 words).                              <<01549>>27285000
  If anything goes wrong, Status is set to explain the error in<<01549>>27290000
general terms, and ErrNum is set to explain exactly what happen<<01549>>27295000
No matter what happens, the file is closed before PCHECKENV ret<<01549>>27300000
                                                               <<01549>>27305000
                BA          I       I                          <<01549>>27310000
  PCHECKENV( EnvFileName, Status, ErrNum )                     <<01549>>27315000
                                                               <<01549>>27320000
_Parameters_                                                   <<01549>>27325000
                                                               <<01549>>27330000
  EnvFileName      byte array (required)                       <<01549>>27335000
                                                               <<01549>>27340000
                   This is the name of an environment file     <<01549>>27345000
                   (produced by PS2680) which is to be opened  <<01549>>27350000
                   for checking.  The name must be terminated  <<01549>>27355000
                   in a manner suitable for passing to FOPEN,  <<01549>>27360000
                   e.g. terminated by a blank.                 <<01549>>27365000
                                                               <<01549>>27370000
  Status           integer (required)                          <<01549>>27375000
                                                               <<01549>>27380000
                   On return, this parameter is set to indicate<<01549>>27385000
                   in general terms what happened when PCHECKEN<<01549>>27390000
                   attempted to open the environment file.     <<01549>>27395000
                   The values taken on by Status here are the  <<01549>>27400000
                   same as the corresponding values for Status <<01549>>27405000
                   returned by PLOADENV.  They are:            <<01549>>27410000
                                                               <<01549>>27415000
                        value                meaning           <<01549>>27420000
                                                               <<01549>>27425000
                          0        Successful.  The environ-   <<01549>>27430000
                                   ment file is OK, as far as  <<01549>>27435000
                                   we can tell without reading <<01549>>27440000
                                   through it.                 <<01549>>27445000
                                                               <<01549>>27450000
                          1        Couldn't open the environ-  <<01549>>27455000
                                   ment file.  ErrNum contains <<01549>>27460000
                                   the MPE error message num-  <<01549>>27465000
                                   ber as returned by FCHECK.  <<01549>>27470000
                                                               <<01549>>27475000
                          2        File supplied exists, but   <<01549>>27480000
                                   isn't an environment file.  <<01549>>27485000
                                   ErrNum contains what was    <<01549>>27490000
                                   wrong.                      <<01549>>27495000
                                                               <<01549>>27500000
                          3        Couldn't read the environ-  <<01549>>27505000
                                   ment file's header. (The    <<01549>>27510000
                                   first record of the file.)  <<01549>>27515000
                                   ErrNum contains FCHECK num. <<01549>>27520000
                                                               <<01549>>27525000
                          4        Nothing in compiled part.   <<01549>>27530000
                                   This environment file must  <<01549>>27535000
                                   be compiled by PS2680       <<01549>>27540000
                                   before it can be used.      <<01549>>27545000
                                                               <<01549>>27550000
                          5        Warning: environment file   <<01549>>27555000
                                   has been changed since last <<01549>>27560000
                                   compiled.                   <<01549>>27565000
                                                               <<01549>>27570000
                          6        Bad environment file. There <<01549>>27575000
                                   was something wrong with    <<01549>>27580000
                                   the environment file's      <<01549>>27585000
                                   internal format.  ErrNum    <<01549>>27590000
                                   says exactly what.          <<01549>>27595000
                                                               <<01549>>27600000
                          8        Couldn't close the environ- <<01549>>27605000
                                   ment file after an error was<<01549>>27610000
                                   detected.  ErrNum contains t<<01549>>27615000
                                   FCHECK number.              <<01549>>27620000
                                                               <<01549>>27625000
                          9        FGETINFO failed.  ErrNum    <<01549>>27630000
                                   contains the FCHECK number. <<01549>>27635000
                                                               <<01884>>27640000
                         10        FILE equation failed,       <<01884>>27645000
                                   possible infinite loop      <<01884>>27650000
                                   such as                     <<01884>>27655000
                                   FILE ENV1 DEV=LP ENV=*ENV1  <<01884>>27660000
$PAGE                                                          <<01549>>27665000
  ErrNum          integer (required)                           <<01549>>27670000
                                                               <<01549>>27675000
                  If an error occurred (as indicated by        <<01549>>27680000
                  a non-zero Status, above) ErrNum will        <<01549>>27685000
                  contain in detail the actual error.  For     <<01549>>27690000
                  errors resulting from MPE intrinsics,        <<01549>>27695000
                  ErrNum containst the error number            <<01549>>27700000
                  returned by FCHECK.  For errors specific     <<01549>>27705000
                  to environment files, ErrNum contains        <<01549>>27710000
                  one of the following values:                 <<01549>>27715000
                                                               <<01549>>27720000
                     (The associated Status value is shown     <<01549>>27725000
                      in parentheses.)                         <<01549>>27730000
                                                               <<01549>>27735000
                        value                meaning           <<01549>>27740000
                                                               <<01549>>27745000
                          1 (2)    File had wrong file code.   <<01549>>27750000
                                                               <<01549>>27755000
                          2 (2)    File had wrong record size. <<01549>>27760000
                                                               <<01549>>27765000
                          3 (6)    The file header was bad.    <<01549>>27770000
                                   This means either that it   <<01549>>27775000
                                   had the wrong record type   <<01549>>27780000
                                   or that the pointer to the  <<01549>>27785000
                                   downloadable stuff was      <<01549>>27790000
                                   invalid.                    <<01549>>27795000
;                                                              <<01549>>27800000
begin                                                          <<01549>>27805000
  << Equates used with environment files. >>                   <<01549>>27810000
  equate                                                       <<01549>>27815000
    cEnvFileCode    = 1112,    << File code for env. files >>  <<01549>>27820000
    cEnvFileRecSize = 512,                                     <<01549>>27825000
    cNil            = %177777, << End-of-list. >>              <<01549>>27830000
    cHeaderRnum     = 0,       << Record # of file header. >>  <<01549>>27835000
    cHeaderRecType  = 10000,   << Rec type of file header. >>  <<01549>>27840000
                                                               <<01549>>27845000
    cRecordTypeWord = 2,       << Offset at which can be   >>  <<01549>>27850000
                               << found the record type of >>  <<01549>>27855000
                               << an env. file record.     >>  <<01549>>27860000
                                                               <<01549>>27865000
    cChangedWord    = 4,       << Offset to the logical    >>  <<01549>>27870000
                               << value indicating whether >>  <<01549>>27875000
                               << this file was changed    >>  <<01549>>27880000
                               << since last compiled.     >>  <<01549>>27885000
                                                               <<01549>>27890000
    cDownloadPtr    = 5;       << Offset in file header at >>  <<01549>>27895000
                               << which the pointer to the >>  <<01549>>27900000
                               << downloadable stuff can   >>  <<01549>>27905000
                               << be found.                >>  <<01549>>27910000
                                                               <<01549>>27915000
  << These are the values which Status can have on return. >>  <<01549>>27920000
                                                               <<01549>>27925000
  equate                                                       <<01549>>27930000
    cSuccessfulOpen   = 0,                                     <<01549>>27935000
    cCouldn'tOpenEnvFile  = 1,                                 <<01549>>27940000
    cNotAnEnvFile         = 2,                                 <<01549>>27945000
    cCouldn'tReadHeader   = 3,                                 <<01549>>27950000
    cEmptyCompiledPart    = 4,                                 <<01549>>27955000
    cChangedSinceCompiled = 5,                                 <<01549>>27960000
    cBadEnvFile           = 6,                                 <<01549>>27965000
    cCouldn'tCloseEnvFile = 8,                                 <<01549>>27970000
    cFGETINFOfailed       = 9,                                 <<01884>>27975000
    cbadfileequation      = 11;                                <<01884>>27980000
                                                               <<01549>>27985000
  << These are the values which ErrNum can have on return. >>  <<01549>>27990000
  <<                                                       >>  <<01549>>27995000
  << ErrNum is undefined if Status is cSuccessfulOpen,     >>  <<01549>>28000000
  << cEmptyCompiledPart, or cChangedSinceCompiled.         >>  <<01549>>28005000
  <<                                                       >>  <<01549>>28010000
  << ErrNum is listed below if Status is cNotAnEnvFile or  >>  <<01549>>28015000
  << cBadEnvFile.                                          >>  <<01549>>28020000
  <<                                                       >>  <<01549>>28025000
  << ErrNum is the value returned by FCHECK if Status is   >>  <<01549>>28030000
  << any other error number. (See above)                   >>  <<01549>>28035000
                                                               <<01549>>28040000
  equate                                                       <<01549>>28045000
    << Status = cNotAnEnvFile >>                               <<01549>>28050000
    cWrongFileCode = 1,                                        <<01549>>28055000
    cWrongRecSize  = 2,                                        <<01549>>28060000
                                                               <<01549>>28065000
    << Status = cBadEnvFile >>                                 <<01549>>28070000
    cBadFileHeader  = 3;                                       <<01549>>28075000
                                                               <<01549>>28080000
  integer                                                      <<01549>>28085000
    FileCode,                                                  <<01549>>28090000
    RecordSize,                                                <<01549>>28095000
    EnvFileNum,                                                <<01549>>28100000
    NextRnum;                                                  <<01549>>28105000
                                                               <<01549>>28110000
  logical array                                                <<01549>>28115000
    EnvRecord(0:cEnvFileRecSize-1);                            <<01549>>28120000
                                                               <<01549>>28125000
   INTEGER                                                     <<01884>>28130000
      BLANKWORD := "  ";                                       <<01884>>28135000
                                                               <<01884>>28140000
   BYTE ARRAY BLANK(0:2) ;                                     <<01884>>28145000
                                                               <<01884>>28150000
   LOGICAL ARRAY DEVPARMS(0:100);                              <<01884>>28155000
                                                               <<01884>>28160000
   LOGICAL                                                     <<01884>>28165000
      ENV'TOKEN := "EN";                                       <<01884>>28170000
                                                               <<01884>>28175000
   INTEGER DP'INDEX,SIZE;                                      <<01884>>28180000
                                                               <<01884>>28185000
   INTEGER ARRAY INFO(0:100);                                  <<01884>>28190000
                                                               <<01884>>28195000
  define dERROR'RETURN =                                       <<01549>>28200000
    begin                                                      <<01549>>28205000
      CLOSE'ENV'FILE;                                          <<01549>>28210000
      return;                                                  <<01549>>28215000
    end #;                                                     <<01549>>28220000
$PAGE "                 PCHECKENV -- SUBROUTINES"              <<01549>>28225000
logical subroutine OKAY'PTR(Ptr);                              <<01549>>28230000
  value Ptr;                                                   <<01549>>28235000
  integer Ptr;                                                 <<01549>>28240000
begin                                                          <<01549>>28245000
  if Ptr > 1 and  << first 2 records are headers >>            <<01549>>28250000
     Ptr < 32767  << largest legal ptr is 32766  >>            <<01549>>28255000
     or Ptr=cNil                                               <<01549>>28260000
  then OKAY'PTR := true                                        <<01549>>28265000
  else OKAY'PTR := false;                                      <<01549>>28270000
end;                                                           <<01549>>28275000
                                                               <<01549>>28280000
logical subroutine OPEN'ENV'FILE;                              <<01549>>28285000
begin                                                          <<01549>>28290000
  OPEN'ENV'FILE := false;  << Assume failure >>                <<01549>>28295000
                                                               <<01549>>28300000
  EnvFileNum := FOPEN(EnvFileName,                             <<01549>>28305000
                      [5/0,   << reserved for MPE >>           <<01549>>28310000
                       1/1,   << disallow file eqns  >>        <<01884>>28315000
                       1/0,                                    <<01549>>28320000
                       1/0,                                    <<01549>>28325000
                       2/0,   << fixed length records >>       <<01549>>28330000
                       3/0,   << actual = formal      >>       <<01549>>28335000
                       1/0,   << binary               >>       <<01549>>28340000
$PAGE                                                          <<06744>>28345000
                       2/3],  << old or oldtemp file  >>       <<06066>>28350000
                                                               <<01549>>28355000
                           0); << Read only.                >> <<04448>>28360000
  if <> then                                                   <<01549>>28365000
  begin                                                        <<01549>>28370000
    Status := cCouldn'tOpenEnvFile;                            <<01549>>28375000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>28380000
    return;                                                    <<01549>>28385000
  end;                                                         <<01549>>28390000
                                                               <<01549>>28395000
  OPEN'ENV'FILE := true;                                       <<01549>>28400000
end;                                                           <<01549>>28405000
$PAGE                                                          <<01549>>28410000
logical subroutine CHECK'VALID'ENV'FILE;                       <<01549>>28415000
begin                                                          <<01549>>28420000
  CHECK'VALID'ENV'FILE := false;                               <<01549>>28425000
                                                               <<01549>>28430000
  FGETINFO(EnvFileNum, <<filename>>, <<foptions>>,             <<01549>>28435000
                       <<aoptions>>,                           <<01549>>28440000
           RecordSize, <<devtype>>,  <<ldnum>>,                <<01549>>28445000
                       <<hdaddr>>,                             <<01549>>28450000
           FileCode);                                          <<01549>>28455000
  if <> then                                                   <<01549>>28460000
  begin                                                        <<01549>>28465000
    Status := cFGETINFOfailed;                                 <<01549>>28470000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>28475000
    return;                                                    <<01549>>28480000
  end;                                                         <<01549>>28485000
                                                               <<01549>>28490000
  if FileCode <> cEnvFileCode then                             <<01549>>28495000
  begin                                                        <<01549>>28500000
    Status := cNotAnEnvFile;                                   <<01549>>28505000
    ErrNum := cWrongFileCode;                                  <<01549>>28510000
    return;                                                    <<01549>>28515000
  end                                                          <<01549>>28520000
  else if RecordSize <> cEnvFileRecSize then                   <<01549>>28525000
  begin                                                        <<01549>>28530000
    Status := cNotAnEnvFile;                                   <<01549>>28535000
    ErrNum := cWrongRecSize;                                   <<01549>>28540000
    return;                                                    <<01549>>28545000
  end;                                                         <<01549>>28550000
                                                               <<01549>>28555000
  CHECK'VALID'ENV'FILE := true;                                <<01549>>28560000
end;                                                           <<01549>>28565000
                                                               <<01549>>28570000
logical subroutine GET'FILE'HEADER;                            <<01549>>28575000
begin                                                          <<01549>>28580000
  GET'FILE'HEADER := false;                                    <<01549>>28585000
                                                               <<01549>>28590000
  FREADDIR(EnvFileNum,EnvRecord,cEnvFileRecSize,               <<01549>>28595000
           double(cHeaderRnum));                               <<01549>>28600000
  if <> then                                                   <<01549>>28605000
  begin                                                        <<01549>>28610000
    Status := cCouldn'tReadHeader;                             <<01549>>28615000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>28620000
    return;                                                    <<01549>>28625000
  end;                                                         <<01549>>28630000
                                                               <<01549>>28635000
  << See if the file header is okay. >>                        <<01549>>28640000
                                                               <<01549>>28645000
  if EnvRecord(cRecordTypeWord) <> cHeaderRecType              <<01549>>28650000
     or not OKAY'PTR(EnvRecord(cDownloadPtr))                  <<01549>>28655000
  then begin                                                   <<01549>>28660000
    Status := cBadEnvFile;                                     <<01549>>28665000
    ErrNum := cBadFileHeader;                                  <<01549>>28670000
    return;                                                    <<01549>>28675000
  end;                                                         <<01549>>28680000
                                                               <<01549>>28685000
  GET'FILE'HEADER := true;                                     <<01549>>28690000
end;                                                           <<01549>>28695000
                                                               <<01549>>28700000
subroutine CLOSE'ENV'FILE;                                     <<01549>>28705000
begin                                                          <<01549>>28710000
  FCLOSE(EnvFileNum,0,0); << Take all defaults >>              <<01549>>28715000
  if <> then                                                   <<01549>>28720000
  begin                                                        <<01549>>28725000
    Status := cCouldn'tCloseEnvFile;                           <<01549>>28730000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>28735000
  end;                                                         <<01549>>28740000
end;                                                           <<01549>>28745000
                                                               <<01884>>28750000
LOGICAL SUBROUTINE CHECK'FILE'EQUATION;                        <<01884>>28755000
BEGIN                                                          <<01884>>28760000
   CHECK'FILE'EQUATION := FALSE;                               <<01884>>28765000
   BLANK := BLANKWORD;                                         <<01884>>28770000
   IF ENVFILENAME <> "*" THEN                                  <<01884>>28775000
      CHECK'FILE'EQUATION := TRUE                              <<01884>>28780000
   ELSE                                                        <<01884>>28785000
   BEGIN  << BACK REFERENCE , CHECK FOR INFINITE LOOP>>        <<01884>>28790000
      IF XRETJTENTRY(ENVFILENAME(1), BLANK, BLANK,             <<01884>>28795000
         SIZE, INFO) <> 0 THEN                                 <<01884>>28800000
         STATUS := cbadfileequation                            <<01884>>28805000
      ELSE                                                     <<01884>>28810000
      BEGIN <<BACK REFERENCE RESULTS IN FILE EQUATION>>        <<01884>>28815000
         DEVPARMS := 0; <<INITIALIZE>>                         <<01884>>28820000
         PARSE'DEV'PARMS(INFO(INFO.(10:6) + 4 +                <<01884>>28825000
            INFO(INFO.(10:6) + 3).(0:8)&LSR(1)),               <<01884>>28830000
            DEVPARMS);                                         <<01884>>28835000
         IF NOT GET'DEV'PARM(ENV'TOKEN, DEVPARMS, DP'INDEX)    <<01884>>28840000
         THEN                                                  <<01884>>28845000
           CHECK'FILE'EQUATION := TRUE                         <<01884>>28850000
         ELSE                                                  <<01884>>28855000
           STATUS := cbadfileequation;                         <<01884>>28860000
      END;                                                     <<01884>>28865000
   END;                                                        <<01884>>28870000
END;  <<SUBROUTINE CHECK'FILE'EQUATION>>                       <<01884>>28875000
                                                               <<01884>>28880000
$PAGE "                PCHECKENV -- MAIN CODE"                 <<01549>>28885000
  Status := cSuccessfulOpen; << Assume success at first >>     <<01549>>28890000
                                                               <<01549>>28895000
   IF NOT CHECK'FILE'EQUATION THEN RETURN;                     <<01884>>28900000
                                                               <<01884>>28905000
  if not OPEN'ENV'FILE then return;                            <<01549>>28910000
                                                               <<01549>>28915000
  IF NOT CHECK'VALID'ENV'FILE THEN                             <<06066>>28920000
     IF PCHECK'LYNXII'ENV (ENVFILENUM, ENVRECORD,              <<06066>>28925000
                           STATUS, ERRNUM)                     <<06066>>28930000
        OR PCHECK'CIPER'ENV (ENVFILENUM, ENVRECORD,            <<06066>>28935000
                             STATUS, ERRNUM) THEN              <<06066>>28940000
           BEGIN   << Not 2680, but LYNXII or CIPER...      >> <<06066>>28945000
           CLOSE'ENV'FILE;   << check is O.K.               >> <<06066>>28950000
           RETURN;                                             <<06066>>28955000
           END     << Not 2680, but LYNXII or CIPER...      >> <<06066>>28960000
     ELSE dERROR'RETURN;   << None of the above, say so.    >> <<06066>>28965000
                                                               <<06066>>28970000
<< P2680 environment file if we get here.                   >> <<06066>>28975000
                                                               <<01549>>28980000
  if not GET'FILE'HEADER      then                             <<01549>>28985000
    dERROR'RETURN;                                             <<01549>>28990000
                                                               <<01549>>28995000
  << If this file has changed since it was last compiled, >>   <<01549>>29000000
  << we will set Status to indicate that.  This is only a >>   <<01549>>29005000
  << warning, however, so we do not do an ERROR'RETURN.   >>   <<01549>>29010000
                                                               <<01549>>29015000
  if EnvRecord(cChangedWord) then                              <<01549>>29020000
    Status := cChangedSinceCompiled;                           <<01549>>29025000
                                                               <<01549>>29030000
  << Start at beginning of download list >>                    <<01549>>29035000
  NextRnum := integer(EnvRecord(cDownloadPtr));                <<01549>>29040000
                                                               <<01549>>29045000
  if NextRnum = cNil then                                      <<01549>>29050000
  begin                                                        <<01549>>29055000
    Status := cEmptyCompiledPart;                              <<01549>>29060000
    dERROR'RETURN;                                             <<01549>>29065000
  end;                                                         <<01549>>29070000
                                                               <<01549>>29075000
  <<** Looks good -- now close the file **>>                   <<01549>>29080000
  CLOSE'ENV'FILE;                                              <<01549>>29085000
                                                               <<01549>>29090000
end;                                                           <<01549>>29095000
$PAGE "                     PLOADENV"                          <<01549>>29100000
procedure PLOADENV( OutFileNum,EnvFileName,                    <<01549>>29105000
                    Status,ErrNum );                           <<01549>>29110000
  value OutFileNum;                                            <<01549>>29115000
  integer                                                      <<01549>>29120000
    OutFileNum,Status,ErrNum;                                  <<01549>>29125000
  byte array                                                   <<01549>>29130000
    EnvFileName;                                               <<01549>>29135000
  OPTION PRIVILEGED, UNCALLABLE;                               <<06066>>29140000
                                                               <<01549>>29145000
comment                                                        <<01549>>29150000
  This procedure is used to include a PSP/3000 environment     <<01549>>29155000
file in an MPE spoolfile.                                      <<01549>>29160000
                                                               <<01549>>29165000
                  IV          BA         I       I             <<01549>>29170000
  PLOADENV (  OutFileNum, EnvFileName, Status, ErrNum  )       <<01549>>29175000
                                                               <<01549>>29180000
_Parameters_                                                   <<01549>>29185000
                                                               <<01549>>29190000
  OutFileNum      integer by value (required)                  <<01549>>29195000
                                                               <<01549>>29200000
                  This is the file number (as returned by      <<01549>>29205000
                  FOPEN) of the output file currently being    <<01549>>29210000
                  created.  This is the file against which     <<01549>>29215000
                  calls to FDEVICECONTROL will be made to      <<01549>>29220000
                  include the environment file.                <<01549>>29225000
                                                               <<01549>>29230000
  EnvFileName     byte array (required)                        <<01549>>29235000
                                                               <<01549>>29240000
                  This is a normal MPE file name, terminated   <<01549>>29245000
                  appropriately so that a call to FOPEN can    <<01549>>29250000
                  be made using EnvFileName with no changes.   <<01549>>29255000
                  PLOADENV will attempt do determine that this <<01549>>29260000
                  file actually is an environment file, and    <<01549>>29265000
                  will fail otherwise.  The file must have a   <<01549>>29270000
                  file code of 1112, and must have record size <<01549>>29275000
                  512 words.  It must also, of course, already <<01549>>29280000
                  exist.                                       <<01549>>29285000
                                                               <<01549>>29290000
  Status          integer (required)                           <<01549>>29295000
                                                               <<01549>>29300000
                  On return, this parameter is set to indicate <<01549>>29305000
                  in general terms what happened when PLOADENV <<01549>>29310000
                  attempted to download the environment file.  <<01549>>29315000
                  The values taken on by Status are:           <<01549>>29320000
                                                               <<01549>>29325000
                        value                meaning           <<01549>>29330000
                                                               <<01549>>29335000
                          0        Successful.  The environ-   <<01549>>29340000
                                   ment file is downloaded.    <<01549>>29345000
                                                               <<01549>>29350000
                          1        Couldn't open the environ-  <<01549>>29355000
                                   ment file.  ErrNum contains <<01549>>29360000
                                   the MPE error message num-  <<01549>>29365000
                                   ber as returned by FCHECK.  <<01549>>29370000
$PAGE                                                          <<01549>>29375000
                          2        File supplied exists, but   <<01549>>29380000
                                   isn't an environment file.  <<01549>>29385000
                                   ErrNum contains what was    <<01549>>29390000
                                   wrong.                      <<01549>>29395000
                                                               <<01549>>29400000
                          3        Couldn't read the environ-  <<01549>>29405000
                                   ment file's header. (The    <<01549>>29410000
                                   first record of the file.)  <<01549>>29415000
                                   ErrNum contains FCHECK num. <<01549>>29420000
                                                               <<01549>>29425000
                          4        Nothing in compiled part.   <<01549>>29430000
                                   This environment file must  <<01549>>29435000
                                   be compiled by PS2680       <<01549>>29440000
                                   before it can be used.      <<01549>>29445000
                                                               <<01549>>29450000
                          5        Warning: environment file   <<01549>>29455000
                                   has been changed since last <<01549>>29460000
                                   compiled.  The old compiled <<01549>>29465000
                                   stuff was downloaded.       <<01549>>29470000
                                                               <<01549>>29475000
                          6        Bad environment file. There <<01549>>29480000
                                   was something wrong with    <<01549>>29485000
                                   the environment file's      <<01549>>29490000
                                   internal format.  ErrNum    <<01549>>29495000
                                   says exactly what.          <<01549>>29500000
                                                               <<01549>>29505000
                          7        Couldn't read a record of   <<01549>>29510000
                                   the environment file.       <<01549>>29515000
                                   ErrNum contains FCHECK num. <<01549>>29520000
                                                               <<01549>>29525000
                          8        Couldn't close the environ- <<01549>>29530000
                                   ment file.  ErrNum contains <<01549>>29535000
                                   the FCHECK number.          <<01549>>29540000
                                                               <<01549>>29545000
                          9        FGETINFO failed.  ErrNum    <<01549>>29550000
                                   contains the FCHECK number. <<01549>>29555000
                                                               <<01549>>29560000
                          10       FDEVICECONTROL failed.      <<01549>>29565000
                                   ErrNum contains the error   <<01549>>29570000
                                   number returned by          <<01549>>29575000
                                   FDEVICECONTROL.             <<01549>>29580000
$PAGE                                                          <<01549>>29585000
  ErrNum          integer (required)                           <<01549>>29590000
                                                               <<01549>>29595000
                  If an error occurred (as indicated by        <<01549>>29600000
                  a non-zero Status, above) ErrNum will        <<01549>>29605000
                  contain in detail the actual error.  For     <<01549>>29610000
                  errors resulting from MPE intrinsics,        <<01549>>29615000
                  ErrNum contains either the error number      <<01549>>29620000
                  returned by the intrinsic (for intrinsics    <<01549>>29625000
                  like FDEVICECONTROL) or the error number     <<01549>>29630000
                  returned by FCHECK (for intrinsics like      <<01549>>29635000
                  FOPEN, FCLOSE, FREADDIR, etc.).  For errors  <<01549>>29640000
                  specific to environment files, ErrNum con-   <<01549>>29645000
                  tains one of the following values:           <<01549>>29650000
                                                               <<01549>>29655000
                     (The associated Status value is shown     <<01549>>29660000
                      in parentheses.)                         <<01549>>29665000
                                                               <<01549>>29670000
                        value                meaning           <<01549>>29675000
                                                               <<01549>>29680000
                          1 (2)    File had wrong file code.   <<01549>>29685000
                                                               <<01549>>29690000
                          2 (2)    File had wrong record size. <<01549>>29695000
                                                               <<01549>>29700000
                          3 (6)    The file header was bad.    <<01549>>29705000
                                   This means either that it   <<01549>>29710000
                                   had the wrong record type   <<01549>>29715000
                                   or that the pointer to the  <<01549>>29720000
                                   downloadable stuff was      <<01549>>29725000
                                   invalid.                    <<01549>>29730000
                                                               <<01549>>29735000
                          4 (6)    A pointer in the list of    <<01549>>29740000
                                   downloadable records was    <<01549>>29745000
                                   illegal.                    <<01549>>29750000
                                                               <<01549>>29755000
                          5 (6)    A record in the list of     <<01549>>29760000
                                   downloadable records had    <<01549>>29765000
                                   an illegal record type.     <<01549>>29770000
                                                               <<01549>>29775000
                          6 (6)    There was no terminator for <<01549>>29780000
                                   a logical record within a   <<01549>>29785000
                                   physical record.            <<01549>>29790000
                                                               <<01549>>29795000
                          7 (6)    A logical record contained  <<01549>>29800000
                                   bad length words.           <<01549>>29805000
                                                               <<01549>>29810000
                          8 (6)    The list of compiled records<<01549>>29815000
                                   contained a loop.  The spool<<01549>>29820000
                                   file now contains a lot of  <<01549>>29825000
                                   garbage.                    <<01549>>29830000
;                                                              <<01549>>29835000
$PAGE                                                          <<01549>>29840000
begin                                                          <<01549>>29845000
  << Equates used with environment files. >>                   <<01549>>29850000
  equate                                                       <<01549>>29855000
    cEnvFileCode    = 1112,    << File code for env. files >>  <<01549>>29860000
    cEnvFileRecSize = 512,                                     <<01549>>29865000
    cNil            = %177777, << End-of-list. >>              <<01549>>29870000
    cHeaderRnum     = 0,       << Record # of file header. >>  <<01549>>29875000
    cHeaderRecType  = 10000,   << Rec type of file header. >>  <<01549>>29880000
                                                               <<01549>>29885000
    cRecordTypeWord = 2,       << Offset at which can be   >>  <<01549>>29890000
                               << found the record type of >>  <<01549>>29895000
                               << an env. file record.     >>  <<01549>>29900000
                                                               <<01549>>29905000
    cChangedWord    = 4,       << Offset to the logical    >>  <<01549>>29910000
                               << value indicating whether >>  <<01549>>29915000
                               << this file was changed    >>  <<01549>>29920000
                               << since last compiled.     >>  <<01549>>29925000
                                                               <<01549>>29930000
    cDownloadPtr    = 5,       << Offset in file header at >>  <<01549>>29935000
                               << which the pointer to the >>  <<01549>>29940000
                               << downloadable stuff can   >>  <<01549>>29945000
                               << be found.                >>  <<01549>>29950000
                                                               <<01549>>29955000
    cNextRec        = 510,     << Offset in an env. record  >> <<01549>>29960000
                               << where ptr to next rec can >> <<01549>>29965000
                               << be found.                 >> <<01549>>29970000
                                                               <<01549>>29975000
    cEndOfDataWord  = 509;     << In an env. record contain->> <<01549>>29980000
                               << ing logical records, this >> <<01549>>29985000
                               << word must have a -1 in it >> <<01549>>29990000
                               << terminating the last log- >> <<01549>>29995000
                               << ical record.              >> <<01549>>30000000
                                                               <<01549>>30005000
  << Offsets into logical records, from the first word in >>   <<01549>>30010000
  << the logical record.  See the 2680A DCS ERS for an    >>   <<01549>>30015000
  << explanation of logical records.                      >>   <<01549>>30020000
                                                               <<01549>>30025000
  equate                                                       <<01549>>30030000
    cLenPlus8 = 0,                                             <<01549>>30035000
    cLen      = 1,                                             <<01549>>30040000
    cFuncCode = 2,                                             <<01549>>30045000
    cP1       = 3,                                             <<01549>>30050000
    cP2       = 4,                                             <<01549>>30055000
    cData     = 5;                                             <<01549>>30060000
                                                               <<01549>>30065000
  << If the value for cLenPlus8 is -1, there are no more >>    <<01549>>30070000
  << logical records in the current physical record.     >>    <<01549>>30075000
                                                               <<01549>>30080000
  equate                                                       <<01549>>30085000
    cEndOfLogRecs = %177777;                                   <<01549>>30090000
$PAGE                                                          <<01549>>30095000
  << These are the values which Status can have on return. >>  <<01549>>30100000
                                                               <<01549>>30105000
  equate                                                       <<01549>>30110000
    cSuccessfulDownload   = 0,                                 <<01549>>30115000
    cCouldn'tOpenEnvFile  = 1,                                 <<01549>>30120000
    cNotAnEnvFile         = 2,                                 <<01549>>30125000
    cCouldn'tReadHeader   = 3,                                 <<01549>>30130000
    cEmptyCompiledPart    = 4,                                 <<01549>>30135000
    cChangedSinceCompiled = 5,                                 <<01549>>30140000
    cBadEnvFile           = 6,                                 <<01549>>30145000
    cCouldn'tReadRecord   = 7,                                 <<01549>>30150000
    cCouldn'tCloseEnvFile = 8,                                 <<01549>>30155000
    cFGETINFOfailed       = 9,                                 <<01549>>30160000
    cFDEVICECONTROLfailed = 10;                                <<01549>>30165000
                                                               <<01549>>30170000
  << These are the values which ErrNum can have on return. >>  <<01549>>30175000
  <<                                                       >>  <<01549>>30180000
  << ErrNum is undefined if Status is cSuccessfulDownLoad, >>  <<01549>>30185000
  << cEmptyCompiledPart, or cChangedSinceCompiled.         >>  <<01549>>30190000
  <<                                                       >>  <<01549>>30195000
  << ErrNum is listed below if Status is cNotAnEnvFile or  >>  <<01549>>30200000
  << cBadEnvFile.                                          >>  <<01549>>30205000
  <<                                                       >>  <<01549>>30210000
  << ErrNum is the value returned by FCHECK if Status is   >>  <<01549>>30215000
  << any other error number. (See above)                   >>  <<01549>>30220000
                                                               <<01549>>30225000
  equate                                                       <<01549>>30230000
    << Status = cNotAnEnvFile >>                               <<01549>>30235000
    cWrongFileCode = 1,                                        <<01549>>30240000
    cWrongRecSize  = 2,                                        <<01549>>30245000
                                                               <<01549>>30250000
    << Status = cBadEnvFile >>                                 <<01549>>30255000
    cBadFileHeader  = 3,                                       <<01549>>30260000
    cPtrBadInList   = 4,                                       <<01549>>30265000
    cIllegalRecType = 5,                                       <<01549>>30270000
    cNoTerminator   = 6,                                       <<01549>>30275000
    cBadLogicalRec  = 7,                                       <<01549>>30280000
    cLoopInList     = 8;                                       <<01549>>30285000
                                                               <<01549>>30290000
  logical array                                                <<01549>>30295000
    EnvRec(0:cEnvFileRecSize-1);                               <<01549>>30300000
  integer                                                      <<01549>>30305000
    EnvFileNum,                                                <<01549>>30310000
    FileCode,                                                  <<01549>>30315000
    RecordSize,                                                <<01549>>30320000
    NextRnum,                                                  <<01549>>30325000
    NextLogRec;                                                <<01549>>30330000
  double                                                       <<01549>>30335000
    NumRecsInFile, << Returned by FGETINFO >>                  <<01549>>30340000
    RecCount;      << # records written to spoolfile so far >> <<01549>>30345000
                                                               <<01549>>30350000
  define dERROR'RETURN =                                       <<01549>>30355000
    begin                                                      <<01549>>30360000
      CLOSE'ENV'FILE;                                          <<01549>>30365000
      return;                                                  <<01549>>30370000
    end #;                                                     <<01549>>30375000
$PAGE "                 PLOADENV -- SUBROUTINES"               <<01549>>30380000
logical subroutine OKAY'PTR(Ptr);                              <<01549>>30385000
  value Ptr;                                                   <<01549>>30390000
  integer Ptr;                                                 <<01549>>30395000
begin                                                          <<01549>>30400000
  if Ptr > 1 and  << first 2 records are headers >>            <<01549>>30405000
     Ptr < 32767  << largest legal ptr is 32766  >>            <<01549>>30410000
     or Ptr=cNil                                               <<01549>>30415000
  then OKAY'PTR := true                                        <<01549>>30420000
  else OKAY'PTR := false;                                      <<01549>>30425000
end;                                                           <<01549>>30430000
                                                               <<01549>>30435000
logical subroutine OPEN'ENV'FILE;                              <<01549>>30440000
begin                                                          <<01549>>30445000
  OPEN'ENV'FILE := false;  << Assume failure >>                <<01549>>30450000
                                                               <<01549>>30455000
  EnvFileNum := FOPEN(EnvFileName,                             <<01549>>30460000
                      [5/0,   << reserved for MPE >>           <<01549>>30465000
                       1/1,   << disallow file eqns  >>        <<01884>>30470000
                       1/0,                                    <<01549>>30475000
                       1/0,                                    <<01549>>30480000
                       2/0,   << fixed length records >>       <<01549>>30485000
                       3/0,   << actual = formal      >>       <<01549>>30490000
                       1/0,   << binary               >>       <<01549>>30495000
                       2/3],  << old or oldtemp file  >>       <<06066>>30500000
                                                               <<01549>>30505000
                           0); << Read only.                >> <<04448>>30510000
  if <> then                                                   <<01549>>30515000
  begin                                                        <<01549>>30520000
    Status := cCouldn'tOpenEnvFile;                            <<01549>>30525000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>30530000
    return;                                                    <<01549>>30535000
  end;                                                         <<01549>>30540000
                                                               <<01549>>30545000
  OPEN'ENV'FILE := true;                                       <<01549>>30550000
end;                                                           <<01549>>30555000
$PAGE                                                          <<01549>>30560000
logical subroutine CHECK'VALID'ENV'FILE(NumRecsInFile);        <<01549>>30565000
  double NumRecsInFile;                                        <<01549>>30570000
begin                                                          <<01549>>30575000
  CHECK'VALID'ENV'FILE := false;                               <<01549>>30580000
                                                               <<01549>>30585000
  FGETINFO(EnvFileNum, <<filename>>, <<foptions>>,             <<01549>>30590000
                       <<aoptions>>,                           <<01549>>30595000
           RecordSize, <<devtype>>,  <<ldnum>>,                <<01549>>30600000
                       <<hdaddr>>,                             <<01549>>30605000
           FileCode,   <<recpt>>,                              <<01549>>30610000
           NumRecsInFile);                                     <<01549>>30615000
  if <> then                                                   <<01549>>30620000
  begin                                                        <<01549>>30625000
    Status := cFGETINFOfailed;                                 <<01549>>30630000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>30635000
    return;                                                    <<01549>>30640000
  end;                                                         <<01549>>30645000
                                                               <<01549>>30650000
  if FileCode <> cEnvFileCode then                             <<01549>>30655000
  begin                                                        <<01549>>30660000
    Status := cNotAnEnvFile;                                   <<01549>>30665000
    ErrNum := cWrongFileCode;                                  <<01549>>30670000
    return;                                                    <<01549>>30675000
  end                                                          <<01549>>30680000
  else if RecordSize <> cEnvFileRecSize then                   <<01549>>30685000
  begin                                                        <<01549>>30690000
    Status := cNotAnEnvFile;                                   <<01549>>30695000
    ErrNum := cWrongRecSize;                                   <<01549>>30700000
    return;                                                    <<01549>>30705000
  end;                                                         <<01549>>30710000
                                                               <<01549>>30715000
  CHECK'VALID'ENV'FILE := true;                                <<01549>>30720000
end;                                                           <<01549>>30725000
                                                               <<01549>>30730000
logical subroutine GET'FILE'HEADER;                            <<01549>>30735000
begin                                                          <<01549>>30740000
  GET'FILE'HEADER := false;                                    <<01549>>30745000
                                                               <<01549>>30750000
  FREADDIR(EnvFileNum,EnvRec,cEnvFileRecSize,                  <<01549>>30755000
           double(cHeaderRnum));                               <<01549>>30760000
  if <> then                                                   <<01549>>30765000
  begin                                                        <<01549>>30770000
    Status := cCouldn'tReadHeader;                             <<01549>>30775000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>30780000
    return;                                                    <<01549>>30785000
  end;                                                         <<01549>>30790000
                                                               <<01549>>30795000
  << See if the file header is okay. >>                        <<01549>>30800000
                                                               <<01549>>30805000
  if EnvRec(cRecordTypeWord) <> cHeaderRecType                 <<01549>>30810000
     or not OKAY'PTR(EnvRec(cDownloadPtr))                     <<01549>>30815000
  then begin                                                   <<01549>>30820000
    Status := cBadEnvFile;                                     <<01549>>30825000
    ErrNum := cBadFileHeader;                                  <<01549>>30830000
    return;                                                    <<01549>>30835000
  end;                                                         <<01549>>30840000
                                                               <<01549>>30845000
  GET'FILE'HEADER := true;                                     <<01549>>30850000
end;                                                           <<01549>>30855000
$PAGE                                                          <<01549>>30860000
logical subroutine READ'COMP'REC(Rnum);                        <<01549>>30865000
  value Rnum;                                                  <<01549>>30870000
  integer Rnum;                                                <<01549>>30875000
                                                               <<01549>>30880000
  comment                                                      <<01549>>30885000
    This subroutine reads record Rnum of the environment       <<01549>>30890000
  file into EnvRec, and then checks to see that that record    <<01549>>30895000
  is actually a compiled (downloadable) one.                   <<01549>>30900000
  ;                                                            <<01549>>30905000
begin                                                          <<01549>>30910000
  READ'COMP'REC := false;                                      <<01549>>30915000
                                                               <<01549>>30920000
  FREADDIR(EnvFileNum,EnvRec,cEnvFileRecSize,                  <<01549>>30925000
           double(Rnum));                                      <<01549>>30930000
  if <> then                                                   <<01549>>30935000
  begin                                                        <<01549>>30940000
    Status := cCouldn'tReadRecord;                             <<01549>>30945000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>30950000
    return;                                                    <<01549>>30955000
  end;                                                         <<01549>>30960000
                                                               <<01549>>30965000
  if EnvRec(cRecordTypeWord) = 128 or                          <<01549>>30970000
     133 <= integer(EnvRec(cRecordTypeWord)) <= 138            <<01549>>30975000
  then                                                         <<01549>>30980000
    READ'COMP'REC := true                                      <<01549>>30985000
  else begin                                                   <<01549>>30990000
    Status := cBadEnvFile;                                     <<01549>>30995000
    ErrNum := cIllegalRecType;                                 <<01549>>31000000
  end;                                                         <<01549>>31005000
end;                                                           <<01549>>31010000
                                                               <<01549>>31015000
subroutine CLOSE'ENV'FILE;                                     <<01549>>31020000
begin                                                          <<01549>>31025000
  FCLOSE(EnvFileNum,0,0); << Take all defaults >>              <<01549>>31030000
  if <> then                                                   <<01549>>31035000
  begin                                                        <<01549>>31040000
    Status := cCouldn'tCloseEnvFile;                           <<01549>>31045000
    FCHECK(EnvFileNum,ErrNum);                                 <<01549>>31050000
  end;                                                         <<01549>>31055000
end;                                                           <<01549>>31060000
$PAGE "                PLOADENV -- MAIN CODE"                  <<01549>>31065000
  Status := cSuccessfulDownload; << Assume success at first >> <<01549>>31070000
                                                               <<01549>>31075000
  if not OPEN'ENV'FILE then return;                            <<01549>>31080000
                                                               <<01549>>31085000
IF NOT CHECK'VALID'ENV'FILE (NUMRECSINFILE) THEN               <<06066>>31090000
   IF PCHECK'LYNXII'ENV (ENVFILENUM, ENVREC,                   <<06066>>31095000
                         STATUS, ERRNUM) THEN                  <<06066>>31100000
      BEGIN                                                    <<06066>>31105000
      PLOAD'LYNXII'ENV (OUTFILENUM, ENVFILENUM, ENVREC,        <<06066>>31110000
                        STATUS, ERRNUM);                       <<06066>>31115000
      RETURN;                                                  <<06066>>31120000
      END                                                      <<06066>>31125000
   ELSE IF PCHECK'CIPER'ENV (ENVFILENUM, ENVREC,               <<06066>>31130000
                             STATUS, ERRNUM) THEN              <<06066>>31135000
      BEGIN                                                    <<06066>>31140000
      PLOAD'CIPER'ENV (OUTFILENUM, ENVFILENUM, ENVREC,         <<06066>>31145000
                       STATUS, ERRNUM);                        <<06066>>31150000
      RETURN;                                                  <<06066>>31155000
      END                                                      <<06066>>31160000
   ELSE dERROR'RETURN;                                         <<06066>>31165000
                                                               <<01549>>31170000
  if not GET'FILE'HEADER      then                             <<01549>>31175000
    dERROR'RETURN;                                             <<01549>>31180000
                                                               <<01549>>31185000
  << If this file has changed since it was last compiled, >>   <<01549>>31190000
  << we will set Status to indicate that.  This is only a >>   <<01549>>31195000
  << warning, however, so we do not do an ERROR'RETURN.   >>   <<01549>>31200000
                                                               <<01549>>31205000
  if EnvRec(cChangedWord) then                                 <<01549>>31210000
    Status := cChangedSinceCompiled;                           <<01549>>31215000
                                                               <<01549>>31220000
  << Start at beginning of download list >>                    <<01549>>31225000
  NextRnum := EnvRec(cDownloadPtr);                            <<01549>>31230000
                                                               <<01549>>31235000
  if NextRnum = cNil then                                      <<01549>>31240000
  begin                                                        <<01549>>31245000
    Status := cEmptyCompiledPart;                              <<01549>>31250000
    dERROR'RETURN;                                             <<01549>>31255000
  end;                                                         <<01549>>31260000
                                                               <<01549>>31265000
  <<** Keep track of the number of records processed.  If this <<01549>>31270000
  <<** ever exceeds the number of records in the file, we have <<01549>>31275000
  <<** encountered a loop in the list of compiled records, so  <<01549>>31280000
  <<** we have a bad environment file.                         <<01549>>31285000
                                                               <<01549>>31290000
  RecCount := 0d;                                              <<01549>>31295000
                                                               <<01549>>31300000
  while NextRnum <> cNil do                                    <<01549>>31305000
  begin                                                        <<01549>>31310000
    if not OKAY'PTR(NextRnum) then                             <<01549>>31315000
    begin                                                      <<01549>>31320000
      Status := cBadEnvFile;                                   <<01549>>31325000
      ErrNum := cPtrBadInList;                                 <<01549>>31330000
      dERROR'RETURN;                                           <<01549>>31335000
    end;                                                       <<01549>>31340000
                                                               <<01549>>31345000
    << Read in the next compiled record >>                     <<01549>>31350000
                                                               <<01549>>31355000
    if not READ'COMP'REC(NextRnum) then                        <<01549>>31360000
      dERROR'RETURN;                                           <<01549>>31365000
                                                               <<01549>>31370000
    << Now go through the compiled record, one logical >>      <<01549>>31375000
    << record at a time.                               >>      <<01549>>31380000
                                                               <<01549>>31385000
    << This variable points to the start of the current >>     <<01549>>31390000
    << logical record.                                  >>     <<01549>>31395000
    NextLogRec := 0;                                           <<01549>>31400000
$PAGE                                                          <<01549>>31405000
    while EnvRec(NextLogRec+cLenPlus8) <> cEndOfLogRecs do     <<01549>>31410000
    begin                                                      <<01549>>31415000
                                                               <<01549>>31420000
      <<** Make sure this logical record is okay. **>>         <<01549>>31425000
                                                               <<01549>>31430000
      if integer(EnvRec(NextLogRec+cLenPlus8)) < 8 then        <<01549>>31435000
      begin                                                    <<01549>>31440000
        Status := cBadEnvFile;                                 <<01549>>31445000
        ErrNum := cBadLogicalRec;                              <<01549>>31450000
        dERROR'RETURN;                                         <<01549>>31455000
      end;                                                     <<01549>>31460000
                                                               <<01549>>31465000
      if integer(EnvRec(NextLogRec+cLenPlus8)) <>              <<01549>>31470000
         integer(EnvRec(NextLogRec+cLen)) + 8                  <<01549>>31475000
      then begin                                               <<01549>>31480000
        Status := cBadEnvFile;                                 <<01549>>31485000
        ErrNum := cBadLogicalRec;                              <<01549>>31490000
        dERROR'RETURN;                                         <<01549>>31495000
      end;                                                     <<01549>>31500000
                                                               <<01549>>31505000
      <<** Download the logical record **>>                    <<01549>>31510000
                                                               <<01549>>31515000
      FDEVICECONTROL( OutFileNum,                              <<01549>>31520000
                      EnvRec(NextLogRec+cData),                <<01549>>31525000
                      -(EnvRec(NextLogRec+cLenPlus8)-8),       <<01549>>31530000
                      EnvRec(NextLogRec+cFuncCode),            <<01549>>31535000
                      EnvRec(NextLogRec+cP1),                  <<01549>>31540000
                      EnvRec(NextLogRec+cP2),                  <<01549>>31545000
                      ErrNum );                                <<01549>>31550000
      if <> then                                               <<01549>>31555000
      begin                                                    <<01549>>31560000
        Status := cFDEVICECONTROLfailed;                       <<01549>>31565000
        dERROR'RETURN;                                         <<01549>>31570000
      end;                                                     <<01549>>31575000
                                                               <<01549>>31580000
      <<** The location of the next logical record is **>>     <<01549>>31585000
      <<** obtained by adding the length of the cur-  **>>     <<01549>>31590000
      <<** rent logical record to the current logical **>>     <<01549>>31595000
      <<** record's position.  The length of the log- **>>     <<01549>>31600000
      <<** ical record is the length of the data,     **>>     <<01549>>31605000
      <<** plus 5 words.  The length of the data in   **>>     <<01549>>31610000
      <<** bytes, plus 8 bytes, is kept as the first  **>>     <<01549>>31615000
      <<** word in the logical record.  If this is    **>>     <<01549>>31620000
      <<** odd, there will be a garbage byte at the   **>>     <<01549>>31625000
      <<** end of the data.  Therefore, we add one to **>>     <<01549>>31630000
      <<** the length plus 8, before dividing by two  **>>     <<01549>>31635000
      <<** to get the length in words.  This is still **>>     <<01549>>31640000
      <<** short by one word, so we add one.          **>>     <<01549>>31645000
                                                               <<01549>>31650000
      NextLogRec := NextLogRec +                               <<01549>>31655000
                    (integer(EnvRec(NextLogRec+cLenPlus8))+1)  <<01549>>31660000
                     / 2 + 1;                                  <<01549>>31665000
                                                               <<01549>>31670000
      if NextLogRec > cEndOfDataWord then                      <<01549>>31675000
      begin  << We went too far >>                             <<01549>>31680000
        Status := cBadEnvFile;                                 <<01549>>31685000
        ErrNum := cNoTerminator;                               <<01549>>31690000
        dERROR'RETURN;                                         <<01549>>31695000
      end;                                                     <<01549>>31700000
                                                               <<01549>>31705000
    end; << _while_ >>                                         <<01549>>31710000
                                                               <<01549>>31715000
    NextRnum := EnvRec(cNextRec);                              <<01549>>31720000
                                                               <<01549>>31725000
    RecCount := RecCount+1d;                                   <<01549>>31730000
    if RecCount > NumRecsInFile then                           <<01549>>31735000
    begin                                                      <<01549>>31740000
      Status := cBadEnvFile;                                   <<01549>>31745000
      ErrNum := cLoopInList;                                   <<01549>>31750000
      dERROR'RETURN;                                           <<01549>>31755000
    end;                                                       <<01549>>31760000
                                                               <<01549>>31765000
  end; << _while_ >>                                           <<01549>>31770000
                                                               <<01549>>31775000
  CLOSE'ENV'FILE;                                              <<01549>>31780000
                                                               <<01549>>31785000
end; << PLOADENV >>                                            <<04382>>31790000
$PAGE "PROCEDURE:  PCHECK'CIPER'ENV"                           <<04382>>31795000
logical procedure PCHECK'CIPER'ENV( Env'file'num,              <<04382>>31800000
                                    Scratch'buffer,            <<04382>>31805000
                                    Return'Status,             <<04382>>31810000
                                    Error'number   );          <<04382>>31815000
                                                               <<04382>>31820000
  integer                           Env'file'num,              <<04382>>31825000
                                    Return'Status,             <<04382>>31830000
                                    Error'number    ;          <<04382>>31835000
                                                               <<04382>>31840000
  logical array                     Scratch'buffer  ;          <<04382>>31845000
  OPTION PRIVILEGED, UNCALLABLE;                               <<06066>>31850000
                                                               <<04382>>31855000
COMMENT                                                        <<04382>>31860000
                                                               <<04382>>31865000
  This procedure is used by PCHECKENV and PLOADENV to validate <<04382>>31870000
an alleged CIPER environment file.  By the time this procedure <<04382>>31875000
is called, the environment file has been opened and determined <<06066>>31880000
not to be either a P2680 or LYNXII environment file.           <<06066>>31885000
                                                               <<04382>>31890000
  Since a CIPER environment file has no special file code or   <<04382>>31895000
record size (in fact it is just an VFC file similar to those   <<04382>>31900000
used for the 2608A printer), the only way to determine validity<<04382>>31905000
is to look for one of the contructs                            <<04382>>31910000
                                                               <<04382>>31915000
      MODE= ,                                                  <<04382>>31920000
      MARGIN= ,                                                <<04382>>31925000
  or  VFC,xx,yyy                                               <<04382>>31930000
                                                               <<04382>>31935000
as the first record in the file.                               <<04382>>31940000
                                                               <<04382>>31945000
  This procedure does not verify that the contents of the file <<04382>>31950000
are correct (nor does the subroutine CHECK'VALID'ENV'FILE used <<04382>>31955000
by PCHECKENV and PLOADENV for P2680 files).  It merely deter-  <<04382>>31960000
mines that the file looks like a CIPER environment file.       <<04382>>31965000
                                                               <<04382>>31970000
  If anything goes wrong during the check, Return'Status is set<<04382>>31975000
to explain the error in general terms, and Error'number is set <<04382>>31980000
to explain exactly what happened.  Regardless of the result,   <<04382>>31985000
the file is left open when PCHECK'CIPER'ENV returns.           <<04382>>31990000
                                                               <<04382>>31995000
  Calling sequence:                                            <<04382>>32000000
                                                               <<04382>>32005000
                                I              LA       I      <<04382>>32010000
    PCHECK'CIPER'ENV( Env'file'num, Scratch'buffer, Status,    <<04382>>32015000
                                I                              <<04382>>32020000
                      Error'number                          )  <<04382>>32025000
                                                               <<04382>>32030000
                                                               <<04382>>32035000
  Parameters:                                                  <<04382>>32040000
                                                               <<04382>>32045000
    Env'file'num    integer (required)                         <<04382>>32050000
                                                               <<04382>>32055000
                    This is the file number of the opened CIPER<<04382>>32060000
                    for checking.                              <<04382>>32065000
                                                               <<04382>>32070000
    Scratch'buffer  logical array (required)                   <<04382>>32075000
                                                               <<04382>>32080000
                    This is (currently) a 512 word array used  <<04382>>32085000
                    by PCHECKENV and PLOADENV for reading re-  <<04382>>32090000
                    cords out of the environment file.  This   <<04382>>32095000
                    procedure uses it for the same purpose.    <<04382>>32100000
                    Since PCHECKENV and PLOADENV always have   <<04382>>32105000
                    this array, it is passed as a parameter to <<04382>>32110000
                    conserve stack space.                      <<04382>>32115000
                                                               <<04382>>32120000
    Return'status   integer (required)                         <<04382>>32125000
                                                               <<04382>>32130000
                    On return, this parameter is set to indi-  <<04382>>32135000
                    cate, in general terms, what happened when <<04382>>32140000
                    PCHECK'CIPER'ENV tried to evaluate the en- <<04382>>32145000
                    vironment file.  The values returned cor-  <<04382>>32150000
                    respond to those returned by PCHECKENV and <<04382>>32155000
                    PLOADENV.  They are:                       <<04382>>32160000
                                                               <<04382>>32165000
                      value               meaning              <<04382>>32170000
                                                               <<04382>>32175000
                        0       Successful.  The environment   <<04382>>32180000
                                file is okay, as far as we can <<04382>>32185000
                                tell without parsing the entire<<04382>>32190000
                                thing.                         <<04382>>32195000
                                                               <<04382>>32200000
                        2       File is not a recognizable en- <<04382>>32205000
                                vironment file.                <<04382>>32210000
                                                               <<04382>>32215000
                        3       Could not read the header re-  <<04382>>32220000
                                cord (record 0).               <<04382>>32225000
                                                               <<04382>>32230000
    Error'number    integer (required)                         <<04382>>32235000
                                                               <<04382>>32240000
                    If an error occurred (as indicated by      <<04382>>32245000
                    zero Return'status, above) Error'number    <<04382>>32250000
                    will contain in detail the actual error.   <<04382>>32255000
                    For errors resulting from MPE intrinsics,  <<04382>>32260000
                    Error'number contains the error number re- <<04382>>32265000
                    turned by FCHECK.  For errors specific to  <<04382>>32270000
                    environment files, Error'number contains   <<04382>>32275000
                    one of the following values:               <<04382>>32280000
                                                               <<04382>>32285000
                    (The associated Return'status value is     <<04382>>32290000
                     shown in parentheses.)                    <<04382>>32295000
                                                               <<04382>>32300000
                      value               meaning              <<04382>>32305000
                                                               <<04382>>32310000
                      9 (2)     File not a CIPER environment.  <<04382>>32315000
                                                               <<04382>>32320000
;                                                              <<04382>>32325000
$PAGE "PROCEDURE:  PCHECK'CIPER'ENV -- LOCAL DECLARATIONS"     <<04382>>32330000
begin                                                          <<04382>>32335000
                                                               <<04382>>32340000
  equate                                                       <<04382>>32345000
                                                               <<04382>>32350000
    max'parms                     = 4                          <<04382>>32355000
      << Maximum number of parameters (VFC,xx,yyy,comment) >>  <<04382>>32360000
                                                               <<04382>>32365000
   ,min'parms                     = 1                          <<04382>>32370000
      << Minimum number of parameters (MARGIN=) >>             <<04382>>32375000
                                                               <<04382>>32380000
  ;                                                            <<04382>>32385000
                                                               <<04382>>32390000
                                                               <<04382>>32395000
  double array                                                 <<04382>>32400000
                                                               <<04382>>32405000
    parm'info(0:max'parms-1)                                   <<04382>>32410000
      << Parameter information array >>                        <<04382>>32415000
                                                               <<04382>>32420000
  ;                                                            <<04382>>32425000
                                                               <<04382>>32430000
                                                               <<04382>>32435000
  double                                                       <<04382>>32440000
                                                               <<04382>>32445000
    this'parm                                                  <<04382>>32450000
      << Contains info for a specific parameter >>             <<04382>>32455000
                                                               <<04382>>32460000
  ;                                                            <<04382>>32465000
                                                               <<04382>>32470000
                                                               <<04382>>32475000
  byte pointer                                                 <<04382>>32480000
                                                               <<04382>>32485000
    parameter                     = this'parm                  <<04382>>32490000
      << Points to first character of a parameter >>           <<04382>>32495000
                                                               <<04382>>32500000
  ;                                                            <<04382>>32505000
                                                               <<04382>>32510000
                                                               <<04382>>32515000
  logical                                                      <<04382>>32520000
                                                               <<04382>>32525000
    l'parm                        = this'parm + 1              <<04382>>32530000
      << Parameter descriptor information >>                   <<04382>>32535000
                                                               <<04382>>32540000
  ;                                                            <<04382>>32545000
                                                               <<04382>>32550000
                                                               <<04382>>32555000
  define                                                       <<04382>>32560000
                                                               <<04382>>32565000
    parm'length                   = l'parm.(0:8) #             <<04382>>32570000
      << Length, in characters, of individual parameter >>     <<04382>>32575000
                                                               <<04382>>32580000
   ,p'alpha                       = l'parm.(8:1) #             <<04382>>32585000
      << True if parameter contains alphabetic characters >>   <<04382>>32590000
                                                               <<04382>>32595000
   ,p'numeric                     = l'parm.(9:1) #             <<04382>>32600000
      << True if parameter contains numeric characters >>      <<04382>>32605000
                                                               <<04382>>32610000
   ,p'special                     = l'parm.(10:1) #            <<04382>>32615000
      << True if parameter contains special characters >>      <<04382>>32620000
      << other than the specified delimiters           >>      <<04382>>32625000
                                                               <<04382>>32630000
   ,p'delimiter                   = l'parm.(11:5) #            <<04382>>32635000
      << Delimiter number (see below) >>                       <<04382>>32640000
                                                               <<04382>>32645000
  ;                                                            <<04382>>32650000
                                                               <<04382>>32655000
                                                               <<04382>>32660000
  equate  << Default delimiter assignments from MYCOMMMAND >>  <<04382>>32665000
                                                               <<04382>>32670000
    comma                         = 0                          <<04382>>32675000
   ,equal                         = 1                          <<04382>>32680000
   ,semicolon                     = 2                          <<04382>>32685000
   ,carriage'return               = 3                          <<04382>>32690000
                                                               <<04382>>32695000
  ;                                                            <<04382>>32700000
                                                               <<04382>>32705000
                                                               <<04382>>32710000
  equate                                                       <<04382>>32715000
                                                               <<04382>>32720000
    cr                            = %15                        <<04382>>32725000
   ,double'cr                     = %6415                      <<04382>>32730000
                                                               <<04382>>32735000
  ;                                                            <<04382>>32740000
                                                               <<04382>>32745000
                                                               <<04382>>32750000
  byte pointer                                                 <<04382>>32755000
                                                               <<04382>>32760000
    b'env'record                                               <<04382>>32765000
      << Set up to point to the Scratch'buffer >>              <<04382>>32770000
                                                               <<04382>>32775000
  ;                                                            <<04382>>32780000
                                                               <<04382>>32785000
                                                               <<04382>>32790000
  integer                                                      <<04382>>32795000
                                                               <<04382>>32800000
    number'of'parameters                                       <<04382>>32805000
      << MYCOMMAND returns the actual number of parameters >>  <<04382>>32810000
      << found in the parsed string.                       >>  <<04382>>32815000
                                                               <<04382>>32820000
   ,read'length                                                <<04382>>32825000
      << The transfer log as returned from FREAD.  >>          <<04382>>32830000
                                                               <<04382>>32835000
  ;                                                            <<04382>>32840000
                                                               <<04382>>32845000
                                                               <<04382>>32850000
  << These are the values which Return'status can have on >>   <<04382>>32855000
  << return:                                              >>   <<04382>>32860000
                                                               <<04382>>32865000
  equate                                                       <<04382>>32870000
                                                               <<04382>>32875000
    cSuccessfulCheck              = 0                          <<04382>>32880000
   ,cNotAnEnvFile                 = 2                          <<04382>>32885000
   ,cCouldn'tReadHeader           = 3                          <<04382>>32890000
                                                               <<04382>>32895000
  ;                                                            <<04382>>32900000
                                                               <<04382>>32905000
                                                               <<04382>>32910000
  << These are the values which Error'number can have on >>    <<04382>>32915000
  << return.                                             >>    <<04382>>32920000
  <<                                                     >>    <<04382>>32925000
  << Error'number is undefined if Return'status is       >>    <<04382>>32930000
  << cSuccessfulDownload.                                >>    <<04382>>32935000
  <<                                                     >>    <<04382>>32940000
  << Error'number is the value returned by FCHECK if     >>    <<04382>>32945000
  << Return'status is cCouldn'tReadHeader.               >>    <<04382>>32950000
                                                               <<04382>>32955000
  equate                                                       <<04382>>32960000
                                                               <<04382>>32965000
    cNotCIPEREnv                  = 9                          <<04382>>32970000
                                                               <<04382>>32975000
  ;                                                            <<04382>>32980000
$PAGE "PROCEDURE:  PCHECK'CIPER'ENV -- PROCEDURE BODY"         <<04382>>32985000
  << First, assume a successful completion, and initialize >>  <<04382>>32990000
  << the return information accordingly.                   >>  <<04382>>32995000
                                                               <<04382>>33000000
  PCHECK'CIPER'ENV := true;                                    <<04382>>33005000
  Return'status := cSuccessfulCheck;                           <<04382>>33010000
  Error'number := cSuccessfulCheck;                            <<04382>>33015000
                                                               <<04382>>33020000
                                                               <<04382>>33025000
  << Next, initialize the byte pointer into the scratch  >>    <<04382>>33030000
  << buffer we are given.                                >>    <<04382>>33035000
                                                               <<04382>>33040000
  @b'env'record := @scratch'buffer & lsl(1);                   <<04382>>33045000
                                                               <<04382>>33050000
                                                               <<04382>>33055000
  << Read the header record from the file >>                   <<04382>>33060000
                                                               <<04382>>33065000
  read'length := fread(env'file'num, scratch'buffer, 36);      <<04382>>33070000
  if <> then                                                   <<04382>>33075000
    begin                                                      <<04382>>33080000
      return'status := cCouldn'tReadHeader;                    <<04382>>33085000
      FCHECK(env'file'num, Error'number);                      <<04382>>33090000
      return;                                                  <<04382>>33095000
    end;                                                       <<04382>>33100000
                                                               <<04382>>33105000
                                                               <<04382>>33110000
  scratch'buffer(read'length) := double'cr;                    <<04382>>33115000
                                                               <<04382>>33120000
                                                               <<04382>>33125000
  << Parse the header record so we can look for a valid >>     <<04382>>33130000
  << command.                                           >>     <<04382>>33135000
                                                               <<04382>>33140000
  MYCOMMAND( b'env'record, << delimiters defaulted >>,         <<04382>>33145000
             max'parms, number'of'parameters, parm'info );     <<04382>>33150000
                                                               <<04382>>33155000
  this'parm := parm'info;                                      <<04382>>33160000
                                                               <<04382>>33165000
                                                               <<04382>>33170000
  << Now look for one of "MODE=", "MARGIN=", or "VFC," >>      <<04382>>33175000
                                                               <<04382>>33180000
  if parm'length > 0 and                                       <<04382>>33185000
     (min'parms <= number'of'parameters <= max'parms) then     <<04382>>33190000
    begin  << First parm must not be null parameter >>         <<04382>>33195000
                                                               <<04382>>33200000
      if parameter = "MARGIN" and parm'length = 6 and          <<04382>>33205000
         p'delimiter = equal then                              <<04382>>33210000
        begin                                                  <<04382>>33215000
          << All okay, so just branch around to the exit >>    <<04382>>33220000
        end                                                    <<04382>>33225000
      else                                                     <<04382>>33230000
        begin                                                  <<04382>>33235000
          if parameter = "MODE" and parm'length = 4 and        <<04382>>33240000
             p'delimiter = equal then                          <<04382>>33245000
            begin                                              <<04382>>33250000
              << All okay, so branch to exit >>                <<04382>>33255000
            end                                                <<04382>>33260000
          else                                                 <<04382>>33265000
            begin                                              <<04382>>33270000
              if parameter = "VFC" and parm'length = 3 and     <<04382>>33275000
                 p'delimiter = comma then                      <<04382>>33280000
                begin                                          <<04382>>33285000
                  << All okay, so branch to exit >>            <<04382>>33290000
                end                                            <<04382>>33295000
              else                                             <<04382>>33300000
                begin                                          <<04382>>33305000
                  PCHECK'CIPER'ENV := false;                   <<04382>>33310000
                  Return'status := cNotAnEnvFile;              <<04382>>33315000
                  Error'number := cNotCiperEnv;                <<04382>>33320000
                end;                                           <<04382>>33325000
            end;                                               <<04382>>33330000
        end;                                                   <<04382>>33335000
                                                               <<04382>>33340000
    end                                                        <<04382>>33345000
  else                                                         <<04382>>33350000
    begin                                                      <<04382>>33355000
                                                               <<04382>>33360000
      PCHECK'CIPER'ENV := false;                               <<04382>>33365000
      Return'status := cNotAnEnvFile;                          <<04382>>33370000
      Error'number := cNotCIPEREnv;                            <<04382>>33375000
                                                               <<04382>>33380000
    end;                                                       <<04382>>33385000
                                                               <<04382>>33390000
end;  << of procedure PCHECK'CIPER'ENV >>                      <<04382>>33395000
$PAGE "PLOAD'CIPER'ENV"                                        <<04382>>33400000
PROCEDURE PLOAD'CIPER'ENV (OUT'FILE'NUM, ENV'FILE'NUM,         <<06066>>33405000
          SCRATCH'BUFFER, RETURN'STATUS, ERROR'NUMBER);        <<06066>>33410000
  VALUE OUT'FILE'NUM, ENV'FILE'NUM;                            <<06066>>33415000
  INTEGER OUT'FILE'NUM, ENV'FILE'NUM, RETURN'STATUS,           <<06066>>33420000
          ERROR'NUMBER;                                        <<06066>>33425000
  LOGICAL ARRAY SCRATCH'BUFFER;                                <<06066>>33430000
  OPTION PRIVILEGED, UNCALLABLE;                               <<06066>>33435000
                                                               <<04382>>33440000
COMMENT                                                        <<04382>>33445000
                                                               <<04382>>33450000
  This procedure is called by PLOADENV to parse a CIPER envir- <<04382>>33455000
onment file and send the results to the specified output file. <<04382>>33460000
PLOADENV will have already opened the environment file and de- <<04382>>33465000
termined that it is neither a P2680 nor a LYNXII environment.  <<06066>>33470000
                                                               <<04382>>33475000
  The output file specified can be either spooled or non-spool-<<04382>>33480000
ed, and this procedure makes no check.  FDEVICECONTROL, which  <<04382>>33485000
is used to transmit the environment commands to the output     <<04382>>33490000
file, will determine if the file is a spoolfile or not.        <<04382>>33495000
                                                               <<04382>>33500000
  If anything goes wrong during the environment load,          <<04382>>33505000
Return'status is set to explain the error in general terms, and<<04382>>33510000
Error'number is set to explain exactly what happened.  Regard- <<04382>>33515000
less of the outcome of the load, the environment file will be  <<04382>>33520000
closed before this procedure returns.                          <<04382>>33525000
                                                               <<04382>>33530000
  Calling sequence:                                            <<04382>>33535000
                                                               <<04382>>33540000
                               I             I                 <<04382>>33545000
    PLOAD'CIPER'ENV( Out'file'num, Env'file'num,               <<04382>>33550000
                                LA              I              <<04382>>33555000
                     Scratch'buffer, Return'status,            <<04382>>33560000
                               I                               <<04382>>33565000
                     Error'number                    )         <<04382>>33570000
                                                               <<04382>>33575000
                                                               <<04382>>33580000
  Parameters:                                                  <<04382>>33585000
                                                               <<04382>>33590000
    Out'file'num    integer (required)                         <<04382>>33595000
                                                               <<04382>>33600000
                    This is the file number of the destination <<04382>>33605000
                    device file.  It may be spooled or non-    <<04382>>33610000
                    spooled.                                   <<04382>>33615000
                                                               <<04382>>33620000
    Env'file'num    integer (required)                         <<04382>>33625000
                                                               <<04382>>33630000
                    This is the file number of the environment <<04382>>33635000
                    file to load.  It is open, but may or may  <<04382>>33640000
                    not be rewound, so a rewind is always per- <<04382>>33645000
                    formed.                                    <<04382>>33650000
                                                               <<04382>>33655000
    Scratch'buffer  logical array (required)                   <<04382>>33660000
                                                               <<04382>>33665000
                    This is (currently) a 512 word array de-   <<04382>>33670000
                    clared by PLOADENV for reading environment <<04382>>33675000
                    file records.  It is passed to this proce- <<04382>>33680000
                    dure, so a local scratch array is not re-  <<04382>>33685000
                    quired.  This is to conserve stack space.  <<04382>>33690000
                                                               <<04382>>33695000
    Return'status   integer (required)                         <<04382>>33700000
                                                               <<04382>>33705000
                    On return, this parameter is set to indi-  <<04382>>33710000
                    cate, in general terms, what happened when <<04382>>33715000
                    PLOAD'CIPER'ENV tried to download the en-  <<04382>>33720000
                    vironment file.  The values returned cor-  <<04382>>33725000
                    respond to those returned by PCHECKENV and <<04382>>33730000
                    PLOADENV.  They are:                       <<04382>>33735000
                                                               <<04382>>33740000
                      value               meaning              <<04382>>33745000
                                                               <<04382>>33750000
                        0       Successful.  The environment   <<04382>>33755000
                                file is downloaded.            <<04382>>33760000
                                                               <<04382>>33765000
                        3       Couldn't read the environment  <<04382>>33770000
                                file's header record.          <<04382>>33775000
                                                               <<04382>>33780000
                        6       Bad environment file.  There   <<04382>>33785000
                                was something wrong with the   <<04382>>33790000
                                environment file's internal    <<04382>>33795000
                                format.                        <<04382>>33800000
                                                               <<04382>>33805000
                        7       Couldn't read a record of the  <<04382>>33810000
                                environment file.              <<04382>>33815000
                                                               <<04382>>33820000
                        8       Couldn't close the environment <<04382>>33825000
                                file.                          <<04382>>33830000
                                                               <<04382>>33835000
                       10       FDEVICECONTROL failed.         <<04382>>33840000
                                Error'number contains the error<<04382>>33845000
                                number returned by             <<04382>>33850000
                                FDEVICECONTROL.                <<04382>>33855000
                                                               <<04382>>33860000
    Error'number    integer (required)                         <<04382>>33865000
                                                               <<04382>>33870000
                    If an error occurred (as indicated by      <<04382>>33875000
                    Return'status, above) Error'number will    <<04382>>33880000
                    contain in detail the actual error.  For   <<04382>>33885000
                    errors resulting from MPE intrinsics,      <<04382>>33890000
                    Error'number contains the error number re- <<04382>>33895000
                    turned by FCHECK.  For errors specific to  <<04382>>33900000
                    environment files, Error'number contains   <<04382>>33905000
                    one of the following values:               <<04382>>33910000
                                                               <<04382>>33915000
                    (The associated Return'status value is     <<04382>>33920000
                     shown in parentheses.)                    <<04382>>33925000
                                                               <<04382>>33930000
                      value               meaning              <<04382>>33935000
                                                               <<04382>>33940000
                      10 (6)    Illegal command or parameter   <<04382>>33945000
                                in CIPER environment.          <<04382>>33950000
                                                               <<04382>>33955000
                                                               <<04382>>33960000
;                                                              <<04382>>33965000
$PAGE "PLOAD'CIPER'ENV -- LOCAL DECLARATIONS"                  <<04382>>33970000
begin                                                          <<04382>>33975000
                                                               <<04382>>33980000
  equate                                                       <<04382>>33985000
                                                               <<04382>>33990000
    max'parms                     = 4                          <<04382>>33995000
      << Maximum number of parameters (VFC,xx,yyy,comment) >>  <<04382>>34000000
                                                               <<04382>>34005000
   ,min'parms                     = 2                          <<04382>>34010000
      << Minimum number of parameters (MARGIN=xx or MODE=xx) >><<04382>>34015000
                                                               <<04382>>34020000
   ,margin'parms                  = 2                          <<04382>>34025000
      << Number of parameters in a valid MARGIN command >>     <<04382>>34030000
                                                               <<04382>>34035000
   ,mode'parms                    = 2                          <<04382>>34040000
      << Number of parameters in a valid MODE= command >>      <<04382>>34045000
                                                               <<04382>>34050000
   ,vfc'parms'w'o'comment         = 3                          <<04382>>34055000
      << Number of parameters in a valid VFC command that >>   <<04382>>34060000
      << has no comment as the last parameter             >>   <<04382>>34065000
                                                               <<04382>>34070000
   ,vfc'parms'w'comment           = 4                          <<04382>>34075000
      << Number of parameters in a valid VFC command that >>   <<04382>>34080000
      << has a comment string as the last parameter       >>   <<04382>>34085000
                                                               <<04382>>34090000
   ,max'vfc'lines                 = 127                        <<04382>>34095000
      << Maximum number of lines in a VFC download >>          <<04382>>34100000
                                                               <<04382>>34105000
   ,max'read'length               = 36                         <<04382>>34110000
      << Maximum count parameter used in FREAD calls >>        <<04382>>34115000
                                                               <<04382>>34120000
   ,vfc'read'length               = 8                          <<04382>>34125000
      << Vfc records are 8 words long >>                       <<04382>>34130000
                                                               <<04382>>34135000
   ,min'margin                    = 1                          <<04382>>34140000
      << Minimum allowed value for left margin >>              <<04382>>34145000
                                                               <<04382>>34150000
   ,max'margin                    = 16                         <<04382>>34155000
      << Maximum allowed value for left margin >>              <<04382>>34160000
                                                               <<04382>>34165000
  ;                                                            <<04382>>34170000
                                                               <<04382>>34175000
                                                               <<04382>>34180000
  double array                                                 <<04382>>34185000
                                                               <<04382>>34190000
    parm'info(0:max'parms-1)                                   <<04382>>34195000
      << Parameter information array >>                        <<04382>>34200000
                                                               <<04382>>34205000
  ;                                                            <<04382>>34210000
                                                               <<04382>>34215000
                                                               <<04382>>34220000
  double                                                       <<04382>>34225000
                                                               <<04382>>34230000
    this'parm                                                  <<04382>>34235000
      << Contains info for a specific parameter >>             <<04382>>34240000
                                                               <<04382>>34245000
  ;                                                            <<04382>>34250000
                                                               <<04382>>34255000
                                                               <<04382>>34260000
  byte pointer                                                 <<04382>>34265000
                                                               <<04382>>34270000
    parameter                     = this'parm                  <<04382>>34275000
      << Points to first character of a parameter >>           <<04382>>34280000
                                                               <<04382>>34285000
  ;                                                            <<04382>>34290000
                                                               <<04382>>34295000
                                                               <<04382>>34300000
  logical                                                      <<04382>>34305000
                                                               <<04382>>34310000
    l'parm                        = this'parm + 1              <<04382>>34315000
      << Parameter descriptor information >>                   <<04382>>34320000
                                                               <<04382>>34325000
  ;                                                            <<04382>>34330000
                                                               <<04382>>34335000
                                                               <<04382>>34340000
  define  << Parameter descriptor sub-fields >>                <<04382>>34345000
                                                               <<04382>>34350000
    parm'length                   = l'parm.(0:8) #             <<04382>>34355000
      << Length, in characters, of individual parameter >>     <<04382>>34360000
                                                               <<04382>>34365000
   ,p'alpha                       = l'parm.(8:1) #             <<04382>>34370000
      << True if parameter contains alphabetic characters >>   <<04382>>34375000
                                                               <<04382>>34380000
   ,p'numeric                     = l'parm.(9:1) #             <<04382>>34385000
      << True if parameter contains numeric characters >>      <<04382>>34390000
                                                               <<04382>>34395000
   ,p'special                     = l'parm.(10:1) #            <<04382>>34400000
      << True if parameter contains special characters >>      <<04382>>34405000
      << other than the specified delimiters           >>      <<04382>>34410000
                                                               <<04382>>34415000
   ,p'delimiter                   = l'parm.(11:5) #            <<04382>>34420000
      << Delimiter number (see below) >>                       <<04382>>34425000
                                                               <<04382>>34430000
  ;                                                            <<04382>>34435000
                                                               <<04382>>34440000
                                                               <<04382>>34445000
  equate  << Default delimiter assignments from MYCOMMMAND >>  <<04382>>34450000
                                                               <<04382>>34455000
    comma                         = 0                          <<04382>>34460000
   ,equal                         = 1                          <<04382>>34465000
   ,semicolon                     = 2                          <<04382>>34470000
   ,carriage'return               = 3                          <<04382>>34475000
                                                               <<04382>>34480000
  ;                                                            <<04382>>34485000
                                                               <<04382>>34490000
                                                               <<04382>>34495000
  equate  << FCONTROL and FDEVICECONTROL function codes: >>    <<04382>>34500000
                                                               <<04382>>34505000
    func'file'rewind              = 5                          <<04382>>34510000
      << Rewind file to start >>                               <<04382>>34515000
                                                               <<04382>>34520000
   ,func'vfu'download             = 64                         <<04382>>34525000
      << Downloads VFC information to Out'file'num >>          <<04382>>34530000
                                                               <<04382>>34535000
   ,func'margin'set               = 65                         <<04382>>34540000
      << Downloads left margin setting to output file >>       <<04382>>34545000
                                                               <<04382>>34550000
   ,func'mode'set                 = 146                        <<04382>>34555000
      << Sets 'feature' or 'transparent' access mode >>        <<04382>>34560000
                                                               <<04382>>34565000
  ;                                                            <<04382>>34570000
                                                               <<04382>>34575000
                                                               <<04382>>34580000
  equate                                                       <<04382>>34585000
                                                               <<04382>>34590000
    double'cr                     = %6415                      <<04382>>34595000
      << Double carriage return for parsing with MYCOMMAND >>  <<04382>>34600000
                                                               <<04382>>34605000
                                                               <<04382>>34610000
  ;                                                            <<04382>>34615000
                                                               <<04382>>34620000
                                                               <<04382>>34625000
  logical array                                                <<04382>>34630000
                                                               <<04382>>34635000
    read'buffer(*)                = Scratch'buffer             <<04382>>34640000
      << Part of the scratch buffer that is used as an >>      <<04382>>34645000
      << input buffer for FREAD calls                  >>      <<04382>>34650000
                                                               <<04382>>34655000
  ;                                                            <<04382>>34660000
                                                               <<04382>>34665000
                                                               <<04382>>34670000
  logical pointer                                              <<04382>>34675000
                                                               <<04382>>34680000
                                                               <<04382>>34685000
    vfc'image                                                  <<04382>>34690000
      << Part of the scratch buffer that is used to con- >>    <<04382>>34695000
      << struct an image of the VFC that later gets sent >>    <<04382>>34700000
      << to the output file                              >>    <<04382>>34705000
                                                               <<04382>>34710000
  ;                                                            <<04382>>34715000
                                                               <<04382>>34720000
                                                               <<04382>>34725000
  byte pointer                                                 <<04382>>34730000
                                                               <<04382>>34735000
    b'read'buffer                                              <<04382>>34740000
      << Set up to point to the Scratch'buffer >>              <<04382>>34745000
                                                               <<04382>>34750000
   ,b'vfc'image                                                <<04382>>34755000
      << byte pointer to the vfc image >>                      <<04382>>34760000
                                                               <<04382>>34765000
  ;                                                            <<04382>>34770000
                                                               <<04382>>34775000
                                                               <<04382>>34780000
  integer                                                      <<04382>>34785000
                                                               <<04382>>34790000
    number'of'parameters                                       <<04382>>34795000
      << MYCOMMAND returns the actual number of parameters >>  <<04382>>34800000
      << found in the parsed string.                       >>  <<04382>>34805000
                                                               <<04382>>34810000
   ,read'length                                                <<04382>>34815000
      << The transfer log as returned from FREAD.  >>          <<04382>>34820000
                                                               <<04382>>34825000
   ,lines'in'file                  := 0                        <<04382>>34830000
      << Number of lines read from environment file >>         <<04382>>34835000
                                                               <<04382>>34840000
   ,parm'num                                                   <<04382>>34845000
      << Index into parm'info descriptor array >>              <<04382>>34850000
                                                               <<04382>>34855000
   ,count                                                      <<04382>>34860000
      << Word count passed to FDEVICECONTROL >>                <<04382>>34865000
                                                               <<04382>>34870000
   ,lines'in'vfc                                               <<04382>>34875000
      << Index to Vfc image under construction >>              <<04382>>34880000
                                                               <<04382>>34885000
   ,channel'index                                              <<04382>>34890000
      << Index to each bit of a VFC line >>                    <<04382>>34895000
                                                               <<04382>>34900000
  ;                                                            <<04382>>34905000
                                                               <<04382>>34910000
                                                               <<04382>>34915000
  logical                                                      <<04382>>34920000
                                                               <<04382>>34925000
    P1                            := 0                         <<04382>>34930000
   ,P2                            := 0                         <<04382>>34935000
   ,dummy'parm                    := 0                         <<04382>>34940000
      << Parameters passed to FCONTROL and FDEVICECONTROL >>   <<04382>>34945000
                                                               <<04382>>34950000
  ;                                                            <<04382>>34955000
                                                               <<04382>>34960000
                                                               <<04382>>34965000
  logical                                                      <<04382>>34970000
                                                               <<04382>>34975000
    mode'encountered               := false                    <<04382>>34980000
      << Set true if a MODE= command is ever found in the >>   <<04382>>34985000
      << environment file                                 >>   <<04382>>34990000
                                                               <<04382>>34995000
   ,margin'encountered             := false                    <<04382>>35000000
      << Set true if a MARGIN= command is ever found in the >> <<04382>>35005000
      << environment file                                   >> <<04382>>35010000
                                                               <<04382>>35015000
   ,vfc'encountered                := false                    <<04382>>35020000
      << Set true if a VFC command is ever found in the  >>    <<04382>>35025000
      << environment file                                >>    <<04382>>35030000
                                                               <<04382>>35035000
   ,channel'one'set                                            <<04382>>35040000
      << Set true if at least one VFC line has channel >>      <<04382>>35045000
      << one set.                                      >>      <<04382>>35050000
                                                               <<04382>>35055000
   ,end'of'file                                                <<04382>>35060000
      << Set true if the end of file is found while looking >> <<04382>>35065000
      << for major commands in the outer block of the pro-  >> <<04382>>35070000
      << cedure.                                            >> <<04382>>35075000
                                                               <<04382>>35080000
  ;                                                            <<04382>>35085000
                                                               <<04382>>35090000
                                                               <<04382>>35095000
  << These are the values which Return'status can have on >>   <<04382>>35100000
  << return:                                              >>   <<04382>>35105000
                                                               <<04382>>35110000
  equate                                                       <<04382>>35115000
                                                               <<04382>>35120000
    cSuccessfulLoad               = 0                          <<04382>>35125000
   ,cNotAnEnvFile                 = 2                          <<04382>>35130000
   ,cCouldn'tReadHeader           = 3                          <<04382>>35135000
   ,cBadEnvFile                   = 6                          <<04382>>35140000
   ,cCouldn'tReadRecord           = 7                          <<04382>>35145000
   ,cCouldn'tCloseEnvFile         = 8                          <<04382>>35150000
   ,cFDEVICECONTROLfailed         = 10                         <<04382>>35155000
   ,cCouldn'tPositionEnvFile      = 12                         <<04382>>35160000
                                                               <<04382>>35165000
  ;                                                            <<04382>>35170000
                                                               <<04382>>35175000
                                                               <<04382>>35180000
  << These are the values which Error'number can have on >>    <<04382>>35185000
  << return.                                             >>    <<04382>>35190000
  <<                                                     >>    <<04382>>35195000
  << Error'number is undefined if Return'status is       >>    <<04382>>35200000
  << cSuccessfulDownload.                                >>    <<04382>>35205000
  <<                                                     >>    <<04382>>35210000
  << Error'number is the value returned by FCHECK if     >>    <<04382>>35215000
  << Return'status is cCouldn'tReadHeader.               >>    <<04382>>35220000
                                                               <<04382>>35225000
  equate                                                       <<04382>>35230000
                                                               <<04382>>35235000
    cNotCIPEREnv                  = 9                          <<04382>>35240000
   ,cSomethingIsWrong             = 10                         <<04382>>35245000
                                                               <<04382>>35250000
  ;                                                            <<04382>>35255000
$PAGE "PLOAD'CIPER'ENV -- SUBROUTINE PROCESS'MODE'COMMAND"     <<04382>>35260000
subroutine Process'MODE'command;                               <<04382>>35265000
                                                               <<04382>>35270000
COMMENT                                                        <<04382>>35275000
                                                               <<04382>>35280000
  This subroutine performs the function of parsing out a       <<04382>>35285000
                                                               <<04382>>35290000
      MODE=[FEATURE/TRANSPARENT]                               <<04382>>35295000
                                                               <<04382>>35300000
command.  If the command is valid, the subroutine will perform <<04382>>35305000
the appropriate FDEVICECONTROL call.  If not valid, both       <<04382>>35310000
Status'return and Error'number will be set to indicate the     <<04382>>35315000
abnormal condition that exists.                                <<04382>>35320000
                                                               <<04382>>35325000
;                                                              <<04382>>35330000
                                                               <<04382>>35335000
begin                                                          <<04382>>35340000
                                                               <<04382>>35345000
  count := P1 := P2 := 0; << Initialize FDEVICECONTROL parms >><<04382>>35350000
                                                               <<04382>>35355000
  if lines'in'file = (if margin'encountered then 2 else 1) then<<04382>>35360000
    begin                                                      <<04382>>35365000
                                                               <<04382>>35370000
      mode'encountered := true;                                <<04382>>35375000
                                                               <<04382>>35380000
      if number'of'parameters = mode'parms then                <<04382>>35385000
        begin                                                  <<04382>>35390000
                                                               <<04382>>35395000
          this'parm := parm'info(parm'num := parm'num + 1);    <<04382>>35400000
                                                               <<04382>>35405000
          P1.(15:1) := parameter = "FEATURE"                   <<04382>>35410000
                       land parm'length = 7;                   <<04382>>35415000
                                                               <<04382>>35420000
          if P1 or parameter = "TRANSPARENT" and parm'length=11<<04382>>35425000
          then                                                 <<04382>>35430000
            begin                                              <<04382>>35435000
                                                               <<04382>>35440000
              FDEVICECONTROL( Out'file'num                     <<04382>>35445000
                             ,Scratch'buffer << placeholder >> <<04382>>35450000
                             ,integer(dummy'parm)  << 0 >>     <<04382>>35455000
                             ,func'mode'set                    <<04382>>35460000
                             ,P1                               <<04382>>35465000
                             ,P2  << 0 >>                      <<04382>>35470000
                             ,Error'number    );               <<04382>>35475000
                                                               <<04382>>35480000
              if <> then                                       <<04382>>35485000
                begin                                          <<04382>>35490000
                                                               <<04382>>35495000
                  Return'status := cFDEVICECONTROLfailed;      <<04382>>35500000
                                                               <<04382>>35505000
                end;                                           <<04382>>35510000
            end                                                <<04382>>35515000
          else                                                 <<04382>>35520000
            begin                                              <<04382>>35525000
                                                               <<04382>>35530000
              Return'status := cBadEnvFile;                    <<04382>>35535000
              Error'number := cSomethingIsWrong;               <<04382>>35540000
                                                               <<04382>>35545000
            end;                                               <<04382>>35550000
        end                                                    <<04382>>35555000
      else                                                     <<04382>>35560000
        begin                                                  <<04382>>35565000
                                                               <<04382>>35570000
          Return'status := cBadEnvFile;                        <<04382>>35575000
          Error'number := cSomethingIsWrong;                   <<04382>>35580000
                                                               <<04382>>35585000
        end;                                                   <<04382>>35590000
                                                               <<04382>>35595000
    end                                                        <<04382>>35600000
  else                                                         <<04382>>35605000
    begin                                                      <<04382>>35610000
                                                               <<04382>>35615000
      Return'status := cBadEnvFile;                            <<04382>>35620000
      Error'number := cSomethingIsWrong;                       <<04382>>35625000
                                                               <<04382>>35630000
    end;                                                       <<04382>>35635000
                                                               <<04382>>35640000
end;  << of subroutine Process'mode'command >>                 <<04382>>35645000
$PAGE "PLOAD'CIPER'ENV -- SUBROUTINE PROCESS'MARGIN'COMMAND"   <<04382>>35650000
subroutine Process'MARGIN'command;                             <<04382>>35655000
                                                               <<04382>>35660000
COMMENT                                                        <<04382>>35665000
                                                               <<04382>>35670000
  This subroutine performs the function of parsing out the     <<04382>>35675000
                                                               <<04382>>35680000
      MARGIN=xx    ( 1 <= xx <= 16 )                           <<04382>>35685000
                                                               <<04382>>35690000
command.  If the command is valid, the appropriate call to     <<04382>>35695000
FDEVICECONTROL will be made.  If not valid, both Status'return <<04382>>35700000
and Error'number will be updated to reflect the error that     <<04382>>35705000
occurred.                                                      <<04382>>35710000
                                                               <<04382>>35715000
;                                                              <<04382>>35720000
begin                                                          <<04382>>35725000
                                                               <<04382>>35730000
  count := P1 := P2 := 0; << Initialize FDEVICECONTROL parms >><<04382>>35735000
                                                               <<04382>>35740000
  if lines'in'file = (if mode'encountered then 2 else 1) then  <<04382>>35745000
    begin                                                      <<04382>>35750000
                                                               <<04382>>35755000
      margin'encountered := true;                              <<04382>>35760000
                                                               <<04382>>35765000
      if number'of'parameters = margin'parms then              <<04382>>35770000
        begin                                                  <<04382>>35775000
                                                               <<04382>>35780000
          this'parm := parm'info(parm'num := parm'num + 1);    <<04382>>35785000
                                                               <<04382>>35790000
          P1 := BINARY( parameter, parm'length );              <<04382>>35795000
          if = and (min'margin <=integer(P1)<= max'margin) then<<04382>>35800000
            begin                                              <<04382>>35805000
                                                               <<04382>>35810000
              P1 := P1 - 1;  << Decrement for driver >>        <<04382>>35815000
                                                               <<04382>>35820000
              FDEVICECONTROL( Out'file'num                     <<04382>>35825000
                             ,Scratch'buffer << placeholder >> <<04382>>35830000
                             ,integer(dummy'parm)  << count >> <<04382>>35835000
                             ,func'margin'set                  <<04382>>35840000
                             ,P1                               <<04382>>35845000
                             ,P2  << 0 >>                      <<04382>>35850000
                             ,Error'number   );                <<04382>>35855000
                                                               <<04382>>35860000
              if <> then                                       <<04382>>35865000
                begin                                          <<04382>>35870000
                                                               <<04382>>35875000
                  Return'status := cFDEVICECONTROLfailed;      <<04382>>35880000
                                                               <<04382>>35885000
                end;                                           <<04382>>35890000
            end                                                <<04382>>35895000
          else                                                 <<04382>>35900000
            begin                                              <<04382>>35905000
                                                               <<04382>>35910000
              Return'status := cBadEnvFile;                    <<04382>>35915000
              Error'number := cSomethingIsWrong;               <<04382>>35920000
                                                               <<04382>>35925000
            end;                                               <<04382>>35930000
        end                                                    <<04382>>35935000
      else                                                     <<04382>>35940000
        begin                                                  <<04382>>35945000
                                                               <<04382>>35950000
          Return'status := cBadEnvFile;                        <<04382>>35955000
          Error'number := cSomethingIsWrong;                   <<04382>>35960000
                                                               <<04382>>35965000
        end;                                                   <<04382>>35970000
    end                                                        <<04382>>35975000
  else                                                         <<04382>>35980000
    begin                                                      <<04382>>35985000
                                                               <<04382>>35990000
      Return'status := cBadEnvFile;                            <<04382>>35995000
      Error'number := cSomethingIsWrong;                       <<04382>>36000000
                                                               <<04382>>36005000
    end;                                                       <<04382>>36010000
                                                               <<04382>>36015000
end;  << of subroutine Process'MARGIN'command >>               <<04382>>36020000
$PAGE "PLOAD'CIPER'ENV -- SUBROUTINE PROCESS'VFC'COMMAND"      <<04382>>36025000
subroutine Process'VFC'command;                                <<04382>>36030000
                                                               <<04382>>36035000
COMMENT                                                        <<04382>>36040000
                                                               <<04382>>36045000
  This subroutine performs the function of parsing out the     <<04382>>36050000
                                                               <<04382>>36055000
      VFC,x,yyy,comment                                        <<04382>>36060000
                                                               <<04382>>36065000
command.  If the command is valid, the appropriate call to     <<04382>>36070000
FDEVICECONTROL will be made.  If not valid, both Status'return <<04382>>36075000
and Error'number will be updated to reflect the error that     <<04382>>36080000
occurred.                                                      <<04382>>36085000
                                                               <<04382>>36090000
;                                                              <<04382>>36095000
                                                               <<04382>>36100000
begin                                                          <<04382>>36105000
                                                               <<04382>>36110000
  count := P1 := P2 := 0; << Initialize FDEVICECONTROL parms >><<04382>>36115000
                                                               <<04382>>36120000
 if lines'in'file = (if margin'encountered and mode'encountered<<04382>>36125000
                        then 3                                 <<04382>>36130000
                        else if margin'encountered             <<04382>>36135000
                             or mode'encountered then 2 else 1)<<04382>>36140000
 then                                                          <<04382>>36145000
                                                               <<04382>>36150000
  begin                                                        <<04382>>36155000
                                                               <<04382>>36160000
  vfc'encountered := true;                                     <<04382>>36165000
                                                               <<04382>>36170000
  if number'of'parameters = vfc'parms'w'comment then           <<04382>>36175000
   begin                                                       <<04382>>36180000
                                                               <<04382>>36185000
   this'parm := parm'info(2);                                  <<04382>>36190000
                                                               <<04382>>36195000
   if p'delimiter <> comma then                                <<04382>>36200000
    begin                                                      <<04382>>36205000
                                                               <<04382>>36210000
    Return'status := cBadEnvFile;                              <<04382>>36215000
    Error'number := cSomethingIsWrong;                         <<04382>>36220000
    return;                                                    <<04382>>36225000
                                                               <<04382>>36230000
    end;                                                       <<04382>>36235000
                                                               <<04382>>36240000
   number'of'parameters := vfc'parms'w'o'comment;              <<04382>>36245000
                                                               <<04382>>36250000
   end;                                                        <<04382>>36255000
                                                               <<04382>>36260000
                                                               <<04382>>36265000
  if number'of'parameters = vfc'parms'w'o'comment then         <<04382>>36270000
   begin                                                       <<04382>>36275000
                                                               <<04382>>36280000
   this'parm := parm'info(parm'num := parm'num + 1);           <<04382>>36285000
                                                               <<04382>>36290000
   if p'delimiter = comma then                                 <<04382>>36295000
    begin                                                      <<04382>>36300000
                                                               <<04382>>36305000
    if parm'length = 0 or parameter = " " then                 <<04382>>36310000
     begin                                                     <<04382>>36315000
                                                               <<04382>>36320000
     P1 := 6;                                                  <<04382>>36325000
                                                               <<04382>>36330000
     end                                                       <<04382>>36335000
    else                                                       <<04382>>36340000
     begin                                                     <<04382>>36345000
                                                               <<04382>>36350000
     P1 := BINARY(parameter, parm'length);                     <<04382>>36355000
                                                               <<04382>>36360000
     if = then                                                 <<04382>>36365000
      begin                                                    <<04382>>36370000
      if P1 <> 6 and P1 <> 8 then P1 := 6; << default to 6 >>  <<04382>>36375000
      end                                                      <<04382>>36380000
     else                                                      <<04382>>36385000
      begin                                                    <<04382>>36390000
      Return'status := cBadEnvFile;                            <<04382>>36395000
      Error'number := cSomethingIsWrong;                       <<04382>>36400000
      return;                                                  <<04382>>36405000
      end;                                                     <<04382>>36410000
                                                               <<04382>>36415000
     end;                                                      <<04382>>36420000
                                                               <<04382>>36425000
      this'parm := parm'info(parm'num := parm'num + 1);        <<04382>>36430000
                                                               <<04382>>36435000
      count := BINARY(parameter, parm'length);                 <<04382>>36440000
                                                               <<04382>>36445000
      if = and ( 0 <= count <= max'vfc'lines ) then            <<04382>>36450000
       begin                                                   <<04382>>36455000
                                                               <<04382>>36460000
       if count = 0 then                                       <<04382>>36465000
        begin                                                  <<04382>>36470000
                                                               <<04382>>36475000
        FDEVICECONTROL( Out'file'num                           <<04382>>36480000
                       ,Scratch'buffer  << placeholder >>      <<04382>>36485000
                       ,count                                  <<04382>>36490000
                       ,func'vfu'download                      <<04382>>36495000
                       ,P1                                     <<04382>>36500000
                       ,P2  << 0 >>                            <<04382>>36505000
                       ,Error'number        );                 <<04382>>36510000
                                                               <<04382>>36515000
        if <> then                                             <<04382>>36520000
         begin                                                 <<04382>>36525000
                                                               <<04382>>36530000
         Return'status := cFDEVICECONTROLfailed;               <<04382>>36535000
                                                               <<04382>>36540000
         end;                                                  <<04382>>36545000
        end                                                    <<04382>>36550000
       else                                                    <<04382>>36555000
        begin                                                  <<04382>>36560000
         vfc'image := 0;                                       <<04382>>36565000
         move vfc'image(1) := vfc'image,(max'vfc'lines);       <<04382>>36570000
                                                               <<04382>>36575000
         lines'in'vfc := 0;                                    <<04382>>36580000
                                                               <<04382>>36585000
         read'buffer := 0;                                     <<04382>>36590000
         move read'buffer(1) := read'buffer,(vfc'read'length); <<04382>>36595000
                                                               <<04382>>36600000
         read'length := FREAD( Env'file'num                    <<04382>>36605000
                              ,read'buffer                     <<04382>>36610000
                              ,vfc'read'length );              <<04382>>36615000
                                                               <<04382>>36620000
         if < then                                             <<04382>>36625000
          begin                                                <<04382>>36630000
          Return'status := cCouldn'tReadRecord;                <<04382>>36635000
          FCHECK( Env'file'num, Error'number );                <<04382>>36640000
          return;                                              <<04382>>36645000
          end;                                                 <<04382>>36650000
                                                               <<04382>>36655000
         while = and lines'in'vfc < max'vfc'lines do           <<04382>>36660000
          begin                                                <<04382>>36665000
                                                               <<04382>>36670000
          channel'index := 15;                                 <<04382>>36675000
                                                               <<04382>>36680000
          do                                                   <<04382>>36685000
           begin                                               <<04382>>36690000
                                                               <<04382>>36695000
           vfc'image(lines'in'vfc) := vfc'image(lines'in'vfc)  <<04382>>36700000
                                    & lsl(1);                  <<04382>>36705000
                                                               <<04382>>36710000
           if b'read'buffer(channel'index) = " "               <<04382>>36715000
           or b'read'buffer(channel'index) = "0" then          <<04382>>36720000
            begin                                              <<04382>>36725000
            << do nothing, vfc'image is already zero >>        <<04382>>36730000
            end                                                <<04382>>36735000
           else                                                <<04382>>36740000
            begin                                              <<04382>>36745000
            if b'read'buffer(channel'index) = "1" then         <<04382>>36750000
             begin                                             <<04382>>36755000
              vfc'image(lines'in'vfc) :=                       <<04382>>36760000
                vfc'image(lines'in'vfc) lor 1;                 <<04382>>36765000
             end                                               <<04382>>36770000
            else                                               <<04382>>36775000
             begin                                             <<04382>>36780000
              Return'status := cBadEnvFile;                    <<04382>>36785000
              Error'number := cSomethingIsWrong;               <<04382>>36790000
              return;                                          <<04382>>36795000
             end;                                              <<04382>>36800000
            end;                                               <<04382>>36805000
           end                                                 <<04382>>36810000
          until (channel'index := channel'index - 1) < 0;      <<04382>>36815000
                                                               <<04382>>36820000
          lines'in'vfc := lines'in'vfc + 1;                    <<04382>>36825000
                                                               <<04382>>36830000
          << get the next record, if any >>                    <<04382>>36835000
                                                               <<04382>>36840000
          read'buffer := 0;                                    <<04382>>36845000
          move read'buffer := read'buffer(1),(vfc'read'length);<<04382>>36850000
                                                               <<04382>>36855000
          read'length := FREAD( Env'file'num                   <<04382>>36860000
                               ,read'buffer                    <<04382>>36865000
                               ,vfc'read'length );             <<04382>>36870000
                                                               <<04382>>36875000
          if < then                                            <<04382>>36880000
           begin                                               <<04382>>36885000
           Return'status := cCouldn'tReadRecord;               <<04382>>36890000
           FCHECK( Env'file'num, Error'number );               <<04382>>36895000
           return;                                             <<04382>>36900000
           end;                                                <<04382>>36905000
                                                               <<04382>>36910000
          end;  << of while = and ... >>                       <<04382>>36915000
                                                               <<04382>>36920000
         << Make sure at least one line has channel one set >> <<04382>>36925000
                                                               <<04382>>36930000
         lines'in'vfc := 0;                                    <<04382>>36935000
         channel'one'set := false;                             <<04382>>36940000
                                                               <<04382>>36945000
         do                                                    <<04382>>36950000
          begin                                                <<04382>>36955000
                                                               <<04382>>36960000
          channel'one'set := channel'one'set                   <<04382>>36965000
                             lor vfc'image(lines'in'vfc);      <<04382>>36970000
                                                               <<04382>>36975000
          end                                                  <<04382>>36980000
         until (lines'in'vfc := lines'in'vfc + 1) = count;     <<04382>>36985000
                                                               <<04382>>36990000
         if not channel'one'set then                           <<04382>>36995000
          begin                                                <<04382>>37000000
                                                               <<04382>>37005000
          Return'status := cBadEnvFile;                        <<04382>>37010000
          Error'number := cSomethingIsWrong;                   <<04382>>37015000
          return;                                              <<04382>>37020000
                                                               <<04382>>37025000
          end;                                                 <<04382>>37030000
                                                               <<04382>>37035000
         << All is okay, so send it to the output file. >>     <<04382>>37040000
                                                               <<04382>>37045000
         FDEVICECONTROL( Out'file'num                          <<04382>>37050000
                        ,vfc'image                             <<04382>>37055000
                        ,count                                 <<04382>>37060000
                        ,func'vfu'download                     <<04382>>37065000
                        ,P1                                    <<04382>>37070000
                        ,P2  << 0 >>                           <<04382>>37075000
                        ,Error'number        );                <<04382>>37080000
                                                               <<04382>>37085000
                                                               <<04382>>37090000
         if <> then                                            <<04382>>37095000
          begin                                                <<04382>>37100000
                                                               <<04382>>37105000
          Return'status := cFDEVICECONTROLfailed;              <<04382>>37110000
                                                               <<04382>>37115000
          end;                                                 <<04382>>37120000
         end;                                                  <<04382>>37125000
        end                                                    <<04382>>37130000
       else                                                    <<04382>>37135000
        begin                                                  <<04382>>37140000
        Return'status := cBadEnvFile;                          <<04382>>37145000
        Error'number := cSomethingIsWrong;                     <<04382>>37150000
        end;                                                   <<04382>>37155000
    end                                                        <<04382>>37160000
   else                                                        <<04382>>37165000
    begin                                                      <<04382>>37170000
    Return'status := cBadEnvFile;                              <<04382>>37175000
    Error'number := cSomethingIsWrong;                         <<04382>>37180000
    end;                                                       <<04382>>37185000
   end                                                         <<04382>>37190000
  else                                                         <<04382>>37195000
   begin                                                       <<04382>>37200000
   Return'status := cBadEnvFile;                               <<04382>>37205000
   Error'number := cSomethingIsWrong;                          <<04382>>37210000
   end;                                                        <<04382>>37215000
  end                                                          <<04382>>37220000
 else                                                          <<04382>>37225000
  begin                                                        <<04382>>37230000
  Return'status := cBadEnvFile;                                <<04382>>37235000
  Error'number := cSomethingIsWrong;                           <<04382>>37240000
  end;                                                         <<04382>>37245000
end;  << of subroutine Process'VFC'command >>                  <<04382>>37250000
$PAGE "PLOAD'CIPER'ENV -- PROCEDURE BODY"                      <<04382>>37255000
  << First, initialize any pointers to various parts of the >> <<04382>>37260000
  << Scratch'buffer array.                                  >> <<04382>>37265000
                                                               <<04382>>37270000
  @b'read'buffer := @scratch'buffer & lsl(1);                  <<04382>>37275000
                                                               <<04382>>37280000
  @vfc'image := @scratch'buffer + max'read'length + 1;         <<04382>>37285000
  @b'vfc'image := @vfc'image & lsl(1);                         <<04382>>37290000
                                                               <<04382>>37295000
                                                               <<04382>>37300000
  << Assume successful completion. >>                          <<04382>>37305000
                                                               <<04382>>37310000
  Return'status := cSuccessfulLoad;                            <<04382>>37315000
  Error'number := cSuccessfulLoad;                             <<04382>>37320000
                                                               <<04382>>37325000
                                                               <<04382>>37330000
  << Rewind the environment file, in case PCHECK'CIPER'ENV >>  <<04382>>37335000
  << has been called first (it reads the first record of   >>  <<04382>>37340000
  << the file).                                            >>  <<04382>>37345000
                                                               <<04382>>37350000
  FCONTROL( Env'file'num, func'file'rewind, dummy'parm );      <<04382>>37355000
                                                               <<04382>>37360000
  if <> then                                                   <<04382>>37365000
    begin                                                      <<04382>>37370000
                                                               <<04382>>37375000
      Return'status := cCouldn'tPositionEnvFile;               <<04382>>37380000
      FCHECK( Env'file'num, Error'number );                    <<04382>>37385000
                                                               <<04382>>37390000
    end;                                                       <<04382>>37395000
                                                               <<04382>>37400000
                                                               <<04382>>37405000
  << The outer loop following will parse one of three types >> <<04382>>37410000
  << of command:                                            >> <<04382>>37415000
  <<                                                        >> <<04382>>37420000
  <<    MODE=xx  or  MARGIN=xx  or  VFC,xx,yyy,comment      >> <<04382>>37425000
  <<                                                        >> <<04382>>37430000
  << The MODE= or MARGIN= can be either the first or second >> <<04382>>37435000
  << line in the file, in any order.  If present, they MUST >> <<04382>>37440000
  << preceed the VFC command.                               >> <<04382>>37445000
                                                               <<04382>>37450000
  End'of'file := false;                                        <<04382>>37455000
                                                               <<04382>>37460000
  while Return'status = 0 and not End'of'file do               <<04382>>37465000
    begin                                                      <<04382>>37470000
                                                               <<04382>>37475000
      read'buffer := 0;                                        <<04382>>37480000
      move read'buffer(1) := read'buffer,(max'read'length);    <<04382>>37485000
                                                               <<04382>>37490000
                                                               <<04382>>37495000
      read'length := FREAD( Env'file'num                       <<04382>>37500000
                           ,read'buffer                        <<04382>>37505000
                           ,max'read'length );                 <<04382>>37510000
      if <> then                                               <<04382>>37515000
        begin                                                  <<04382>>37520000
                                                               <<04382>>37525000
          if > then                                            <<04382>>37530000
            begin                                              <<04382>>37535000
                                                               <<04382>>37540000
              End'of'file := true;                             <<04382>>37545000
                                                               <<04382>>37550000
            end                                                <<04382>>37555000
          else                                                 <<04382>>37560000
            begin                                              <<04382>>37565000
                                                               <<04382>>37570000
              Return'status := cCouldn'tReadRecord;            <<04382>>37575000
              FCHECK(env'file'num, Error'number );             <<04382>>37580000
                                                               <<04382>>37585000
            end;                                               <<04382>>37590000
                                                               <<04382>>37595000
        end                                                    <<04382>>37600000
      else                                                     <<04382>>37605000
        begin                                                  <<04382>>37610000
                                                               <<04382>>37615000
          lines'in'file := lines'in'file + 1;                  <<04382>>37620000
                                                               <<04382>>37625000
          if vfc'encountered then                              <<04382>>37630000
            begin                                              <<04382>>37635000
                                                               <<04382>>37640000
              Return'status := cBadEnvFile;                    <<04382>>37645000
              Error'number := cSomethingIsWrong;               <<04382>>37650000
                                                               <<04382>>37655000
            end                                                <<04382>>37660000
          else                                                 <<04382>>37665000
            begin                                              <<04382>>37670000
                                                               <<04382>>37675000
              read'buffer(read'length) := double'cr;           <<04382>>37680000
                                                               <<04382>>37685000
              MYCOMMAND(b'read'buffer,,max'parms,              <<04382>>37690000
                        number'of'parameters, parm'info);      <<04382>>37695000
                                                               <<04382>>37700000
              this'parm := parm'info(parm'num := 0);           <<04382>>37705000
                                                               <<04382>>37710000
              if parameter = "MODE" and parm'length = 4        <<04382>>37715000
                 and p'delimiter = equal then                  <<04382>>37720000
                begin                                          <<04382>>37725000
                                                               <<04382>>37730000
                  Process'MODE'command;                        <<04382>>37735000
                                                               <<04382>>37740000
                end                                            <<04382>>37745000
              else                                             <<04382>>37750000
                begin                                          <<04382>>37755000
                                                               <<04382>>37760000
                  if parameter = "MARGIN" and parm'length = 6  <<04382>>37765000
                     and p'delimiter = equal then              <<04382>>37770000
                    begin                                      <<04382>>37775000
                                                               <<04382>>37780000
                      Process'MARGIN'command;                  <<04382>>37785000
                                                               <<04382>>37790000
                    end                                        <<04382>>37795000
                  else                                         <<04382>>37800000
                    begin                                      <<04382>>37805000
                                                               <<04382>>37810000
                      if parameter = "VFC" and parm'length = 3 <<04382>>37815000
                         and p'delimiter = comma then          <<04382>>37820000
                        begin                                  <<04382>>37825000
                                                               <<04382>>37830000
                          Process'VFC'command;                 <<04382>>37835000
                                                               <<04382>>37840000
                        end                                    <<04382>>37845000
                      else                                     <<04382>>37850000
                        begin                                  <<04382>>37855000
                                                               <<04382>>37860000
                          Return'status := cBadEnvFile;        <<04382>>37865000
                          Error'number := cSomethingIsWrong;   <<04382>>37870000
                                                               <<04382>>37875000
                        end;                                   <<04382>>37880000
                    end;                                       <<04382>>37885000
                end;                                           <<04382>>37890000
            end;                                               <<04382>>37895000
        end;                                                   <<04382>>37900000
    end;  << of while Return'status = 0 . . . >>               <<04382>>37905000
                                                               <<04382>>37910000
                                                               <<04382>>37915000
  << Close the environment file, now that we are finished >>   <<04382>>37920000
  << with it                                              >>   <<04382>>37925000
                                                               <<04382>>37930000
  FCLOSE( Env'file'num, 0, 0 );                                <<04382>>37935000
                                                               <<04382>>37940000
  if <> then                                                   <<04382>>37945000
    begin                                                      <<04382>>37950000
                                                               <<04382>>37955000
      Return'status := cCouldn'tCloseEnvFile;                  <<04382>>37960000
      FCHECK( Env'file'num, Error'number );                    <<04382>>37965000
                                                               <<04382>>37970000
    end;                                                       <<04382>>37975000
                                                               <<04382>>37980000
                                                               <<04382>>37985000
end;  << of procedure PLOAD'CIPER'ENV >>                       <<04382>>37990000
$PAGE "PCHECK'LYNXII'ENV"                                      <<06066>>37995000
$CONTROL SEGMENT = SPOOLCOMS1                                  <<06066>>38000000
                                                               <<06066>>38005000
LOGICAL PROCEDURE PCHECK'LYNXII'ENV (ENV'FILE'NUM, ENV'REC,    <<06066>>38010000
        RETURN'STATUS, ERROR'NUM);                             <<06066>>38015000
  VALUE ENV'FILE'NUM;                                          <<06066>>38020000
  INTEGER ENV'FILE'NUM, RETURN'STATUS, ERROR'NUM;              <<06066>>38025000
  LOGICAL ARRAY ENV'REC;                                       <<06066>>38030000
  OPTION PRIVILEGED, UNCALLABLE;                               <<06066>>38035000
                                                               <<06066>>38040000
BEGIN COMMENT --                                               <<06066>>38045000
  PCHECK'LYNXII'ENV is called by  PCHECKENV  and  PLOADENV  to <<06066>>38050000
determine  whether or not ENV'FILE'NUM is a LYNXII environment <<06066>>38055000
file (by this time, a 2680 and CIPER environment file have al- <<06066>>38060000
ready been tried and have failed).  Since the validity of  the <<06066>>38065000
contents  of ENV'FILE'NUM can only be determined by the LYNXII <<06066>>38070000
software, our only check here is for  a  file  code  of  1177. <<06066>>38075000
(PLOADENV and PCHECKENV have already checked for existence and <<06066>>38080000
access to the file).                                           <<06066>>38085000
  Of the two error  indicators,  RETURN'STATUS  generally  ex- <<06066>>38090000
plains  what went wrong here, while ERROR'NUM is more specific <<06066>>38095000
or is used to return any File System error code which occurs.  <<06066>>38100000
                                                               <<06066>>38105000
  Parameters (all required, no option variable):               <<06066>>38110000
INTEGER                                                        <<06066>>38115000
  ENV'FILE'NUM     Input value parameter.  The file number  of <<06066>>38120000
                   the opened LYNXII environment file.         <<06066>>38125000
                                                               <<06066>>38130000
  RETURN'STATUS    Output reference parameter.  Indicates  the <<06066>>38135000
                   termination  status  of  PCHECK'LYNXII'ENV. <<06066>>38140000
                   Values are a subset of  those  returned  by <<06066>>38145000
                   PCHECKENV:                                  <<06066>>38150000
                                                               <<06066>>38155000
                     Value              Meaning                <<06066>>38160000
                                                               <<06066>>38165000
                       0       No error, as far as we can  de- <<06066>>38170000
                               termine.                        <<06066>>38175000
                                                               <<06066>>38180000
                       2       ENV'FILE'NUM is  not  a  LYNXII <<06066>>38185000
                               terminal   configuration   file <<06066>>38190000
                               (filecode <> 1177).             <<06066>>38195000
                                                               <<06066>>38200000
                       9       FGETINFO  call   to   determine <<06066>>38205000
                               filecode failed.                <<06066>>38210000
                                                               <<06066>>38215000
  ERROR'NUM        Output reference parameter.  A further  re- <<06066>>38220000
                   finement of RETURN'STATUS. If a File System <<06066>>38225000
                   call failed, ERROR'NUM is the error  number <<06066>>38230000
                   returned by FCHECK.  Values returned are:   <<06066>>38235000
                                                               <<06066>>38240000
                     Value              Meaning                <<06066>>38245000
                                                               <<06066>>38250000
                       0       No error.                       <<06066>>38255000
                                                               <<06066>>38260000
                       1       Wrong file code.  RETURN'STATUS <<06066>>38265000
                               = 2.                            <<06066>>38270000
                                                               <<06066>>38275000
                    FCHECK     FGETINFO call  failed.  RETURN' <<06066>>38280000
                    err num    STATUS = 9.                     <<06066>>38285000
                                                               <<06066>>38290000
LOGICAL ARRAY                                                  <<06066>>38295000
  SCRATCH'BUFFER   Reference parameter.  Currently unused. In- <<06066>>38300000
                   cluded in case future checks include  read- <<06066>>38305000
                   ing from ENV'FILE'NUM.                      <<06066>>38310000
                                                               <<06066>>38315000
  Condition code:  Not changed.                                <<06066>>38320000
                                                               <<06066>>38325000
  Special considerations:  DB must be at the stack.            <<06066>>38330000
;                                                              <<06066>>38335000
EQUATE                                                         <<06066>>38340000
   FGETINFO'FAILED     =    9,   << RETURN'STATUS value.    >> <<06066>>38345000
   LYNXII'ENV'FILE     = 1177,   << File code.              >> <<06066>>38350000
   NO'ERROR            =    0,                                 <<06066>>38355000
   NOT'LYNXII'ENV'FILE =    2,   << RETURN'STATUS value.    >> <<06066>>38360000
   WRONG'FILE'CODE     =    1;   << ERROR'NUM     value.    >> <<06066>>38365000
                                                               <<06066>>38370000
INTEGER                                                        <<06066>>38375000
   FILE'CODE;                    << as read by FGETINFO.    >> <<06066>>38380000
                                                               <<06066>>38385000
<< Procedure body starts here.                              >> <<06066>>38390000
                                                               <<06066>>38395000
PCHECK'LYNXII'ENV := FALSE;                                    <<06066>>38400000
FGETINFO (ENV'FILE'NUM, <<filename>>, <<foptions>>,            <<06066>>38405000
          <<aoptions>>, <<recsize>>, <<devtype>>, <<ldnum>>,   <<06066>>38410000
          <<hdaddr>>, FILE'CODE);                              <<06066>>38415000
IF <> THEN                                                     <<06066>>38420000
   BEGIN                                                       <<06066>>38425000
   RETURN'STATUS := FGETINFO'FAILED;                           <<06066>>38430000
   FCHECK (ENV'FILE'NUM, ERROR'NUM);                           <<06066>>38435000
   RETURN;                                                     <<06066>>38440000
   END;                                                        <<06066>>38445000
IF FILE'CODE <> LYNXII'ENV'FILE THEN                           <<06066>>38450000
   BEGIN                                                       <<06066>>38455000
   RETURN'STATUS := NOT'LYNXII'ENV'FILE;                       <<06066>>38460000
   ERROR'NUM     := WRONG'FILE'CODE;                           <<06066>>38465000
   RETURN;                                                     <<06066>>38470000
   END;                                                        <<06066>>38475000
RETURN'STATUS := ERROR'NUM := NO'ERROR;                        <<06066>>38480000
PCHECK'LYNXII'ENV := TRUE;                                     <<06066>>38485000
END;   << of PCHECK'LYNXII'ENV.                             >> <<06066>>38490000
$PAGE "PLOAD'LYNXII'ENV"                                       <<06066>>38495000
$CONTROL SEGMENT = SPOOLCOMS1                                  <<06066>>38500000
                                                               <<06066>>38505000
PROCEDURE PLOAD'LYNXII'ENV (OUT'FILE'NUM, ENV'FILE'NUM,        <<06066>>38510000
          SCRATCH'BUFFER, RETURN'STATUS, ERROR'NUM);           <<06066>>38515000
  VALUE OUT'FILE'NUM, ENV'FILE'NUM;                            <<06066>>38520000
  INTEGER OUT'FILE'NUM, ENV'FILE'NUM, RETURN'STATUS, ERROR'NUM;<<06066>>38525000
  LOGICAL ARRAY SCRATCH'BUFFER;                                <<06066>>38530000
  OPTION PRIVILEGED, UNCALLABLE;                               <<06066>>38535000
                                                               <<06066>>38540000
BEGIN COMMENT --                                               <<06066>>38545000
  PLOAD'LYNXII'ENV is called by  PLOADENV  to  send  a  LYNXII <<06066>>38550000
terminal configuration file (ENV'FILE'NUM) to the device spec- <<06066>>38555000
ified by OUT'FILE'NUM.  PLOADENV has already  opened  the  en- <<06066>>38560000
vironment  file  and determined that it is not a 2680 environ- <<06066>>38565000
ment file.                                                     <<06066>>38570000
  OUT'FILE'NUM may be spooled or non-spooled.  It will usually <<06066>>38575000
be non-spooled, since we are dealing mostly with terminals. On <<06066>>38580000
occasion OUT'FILE'NUM represents a line printer, which may  be <<06066>>38585000
either.  This  procedure  doesn't  care which, leaving any re- <<06066>>38590000
quired checks to the FDEVICECONTROL intrinsic.                 <<06066>>38595000
  No matter the result of  PLOAD'LYNXII'ENV,  the  environment <<06066>>38600000
file (ENV'FILE'NUM) will always be closed on return unless the <<06066>>38605000
FCLOSE fails (see error codes below).                          <<06066>>38610000
  If an error occurs, either here, in FDEVICECONTROL or deeper <<06066>>38615000
than that, RETURN'STATUS and ERROR'NUM take on  the  following <<06066>>38620000
subset of possible values from PLOADENV:                       <<06066>>38625000
                                                               <<06066>>38630000
  RETURN'STATUS   Value      Meaning                           <<06066>>38635000
                                                               <<06066>>38640000
                    0     No error.                            <<06066>>38645000
                                                               <<06066>>38650000
                    8     FCLOSE failed on ENV'FILE'NUM.       <<06066>>38655000
                                                               <<06066>>38660000
                    9     FGETINFO call to get actual designa- <<06066>>38665000
                          tor failed.                          <<06066>>38670000
                                                               <<06066>>38675000
                   10     FDEVICECONTROL reported an error.    <<06066>>38680000
                                                               <<06066>>38685000
                                                               <<06066>>38690000
  ERROR'NUM         0     No error.                            <<06066>>38695000
                                                               <<06066>>38700000
                 <> 0     File System  error  number  (RETURN' <<06066>>38705000
                          STATUS = 8, 9 or 10).                <<06066>>38710000
                                                               <<06066>>38715000
Condition code:  Not changed                                   <<06066>>38720000
                                                               <<06066>>38725000
Special considerations:  DB must be at the stack.              <<06066>>38730000
;                                                              <<06066>>38735000
EQUATE                                                         <<06066>>38740000
   CR                   = %15,  << ASCII carriage return.   >> <<06066>>38745000
   DOWNLOAD'TERM'CONFIG =   1,  << FDEVICECONTROL P1   parm >> <<06066>>38750000
   FCLOSE'FAILED        =   8,  << RETURN'STATUS value.     >> <<06066>>38755000
   FGETINFO'FAILED      =   9,  << RETURN'STATUS value.     >> <<06066>>38760000
   FDVCNTRL'FAILED      =  10,  << RETURN'STATUS value.     >> <<06066>>38765000
   LYNXII'CNTRL'CODE    = 192,  << FDEVICECONTROL CODE parm >> <<06066>>38770000
   LYNXII'WRITE         =   2,  << FDEVICECONTROL P2   parm >> <<06066>>38775000
   NO'ERROR             =   0,                                 <<06066>>38780000
   OLDPASS              =   3;  << FOPTIONS field.          >> <<06066>>38785000
                                                               <<06066>>38790000
INTEGER                                                        <<06066>>38795000
   FOPTIONS,                    << Returned by FGETINFO.    >> <<06066>>38800000
   NAME'LENGTH;                 << #bytes in ENV'FILE'NAME. >> <<06066>>38805000
                                                               <<06066>>38810000
LOGICAL ARRAY                                                  <<06066>>38815000
   ENV'FILE'NAME'L(0:19);                                      <<06066>>38820000
                                                               <<06066>>38825000
BYTE ARRAY                                                     <<06066>>38830000
   ENV'FILE'NAME(*) = ENV'FILE'NAME'L; << Retd by FGETINFO. >> <<06066>>38835000
                                                               <<06066>>38840000
DEFINE                                                         <<06066>>38845000
   DEFAULT'DESIGNATOR = FOPTIONS.(10:3)#;                      <<06066>>38850000
                                                               <<06066>>38855000
<< Procedure body starts here.                              >> <<06066>>38860000
                                                               <<06066>>38865000
RETURN'STATUS := ERROR'NUM := NO'ERROR;                        <<06066>>38870000
FGETINFO (ENV'FILE'NUM, ENV'FILE'NAME, FOPTIONS);              <<06066>>38875000
IF <> THEN                                                     <<06066>>38880000
   BEGIN                                                       <<06066>>38885000
   RETURN'STATUS := FGETINFO'FAILED;                           <<06066>>38890000
   FCHECK (ENV'FILE'NUM, ERROR'NUM);                           <<06066>>38895000
   GO CLOSE'ENV'FILE;                                          <<06066>>38900000
   END;                                                        <<06066>>38905000
IF DEFAULT'DESIGNATOR = OLDPASS THEN                           <<06066>>38910000
   BEGIN   << Environment file is $OLDPASS.                 >> <<06066>>38915000
   MOVE ENV'FILE'NAME := ("$OLDPASS", CR);                     <<06066>>38920000
   NAME'LENGTH := 9;                                           <<06066>>38925000
   END     << Environment file is $OLDPASS.                 >> <<06066>>38930000
ELSE                                                           <<06066>>38935000
   BEGIN   << No other $file allowed, use ENV'FILE'NAME.    >> <<06066>>38940000
   ENV'FILE'NAME(37) := CR;   << Delimit MOVEs which follow >> <<06066>>38945000
   MOVE ENV'FILE'NAME := ENV'FILE'NAME WHILE AN, 0;            <<06066>>38950000
   IF BPS0 = "." THEN                                          <<06066>>38955000
      BEGIN   << Scan group name.                           >> <<06066>>38960000
      MOVE * := *, (1), 1;   << Skip over "." first.        >> <<06066>>38965000
      MOVE * := * WHILE AN, 0;                                 <<06066>>38970000
      IF BPS0 = "." THEN                                       <<06066>>38975000
         BEGIN   << Scan account name.                      >> <<06066>>38980000
         MOVE * := *, (1), 1;   << Skip over "."            >> <<06066>>38985000
         MOVE * := * WHILE AN, 0;                              <<06066>>38990000
         END;    << Scan account name.                      >> <<06066>>38995000
      END;       << Scan group name.                        >> <<06066>>39000000
   BPS0 := CR;   << Delimit name.                           >> <<06066>>39005000
   NAME'LENGTH := TOS - @ENV'FILE'NAME + 1;                    <<06066>>39010000
   DEL;    << Pops destination, source popped in prev line. >> <<06066>>39015000
   END;    << No other $file allowed, use ENV'FILE'NAME.    >> <<06066>>39020000
FDEVICECONTROL (OUT'FILE'NUM, ENV'FILE'NAME'L, -NAME'LENGTH,   <<06066>>39025000
                LYNXII'CNTRL'CODE, DOWNLOAD'TERM'CONFIG,       <<06066>>39030000
                LYNXII'WRITE, ERROR'NUM);                      <<06066>>39035000
IF <> THEN RETURN'STATUS := FDVCNTRL'FAILED;                   <<06066>>39040000
                                                               <<06066>>39045000
CLOSE'ENV'FILE:                                                <<06066>>39050000
                                                               <<06066>>39055000
FCLOSE (ENV'FILE'NUM, 0, 0);                                   <<06066>>39060000
IF <> THEN                                                     <<06066>>39065000
   BEGIN                                                       <<06066>>39070000
   RETURN'STATUS := FCLOSE'FAILED;                             <<06066>>39075000
   FCHECK (ENV'FILE'NUM, ERROR'NUM);                           <<06066>>39080000
   END;                                                        <<06066>>39085000
END;   << of PLOAD'LYNXII'ENV.                              >> <<06066>>39090000
$PAGE "CHECKASS'CLASS - SEE IF DEVCLASS ASSOC W/ USER"         <<04833>>39095000
$CONTROL SEGMENT=SPOOLCOMS2                                    <<04833>>39100000
                                                                        39105000
<< Note:  Procedure CHECKASS'CLASS was moved unchanged from >> <<04833>>39110000
<< OPCOMMAND to SPOOLCOMS as part of this enhancement.  Its >> <<04833>>39115000
<< fix number(s) were not changed.                          >> <<04833>>39120000
                                                                        39125000
LOGICAL PROCEDURE CHECKASS'CLASS(CLASS'INDEX,CLASS'NAME,       <<04833>>39130000
                                 ERROR'RETURN);                <<04833>>39135000
VALUE CLASS'INDEX;                                             <<04833>>39140000
INTEGER                                                        <<04833>>39145000
   CLASS'INDEX,                                                <<04833>>39150000
   ERROR'RETURN;                                               <<04833>>39155000
BYTE ARRAY                                                     <<04833>>39160000
   CLASS'NAME;                                                 <<04833>>39165000
OPTION PRIVILEGED,UNCALLABLE,VARIABLE;                         <<04833>>39170000
COMMENT                                                        <<04833>>39175000
   THE PROCEDURE EXPECTS ONE AND ONLY ONE OF THE CLASS'INDEX   <<04833>>39180000
   OR CLASS'NAME. WILL RETURN TRUE IF THE CLASS'NAME OR CLASS  <<04833>>39185000
   INDEX POINT TO CLASSES WHICH ARE CURRENTLY ASSOCIATED WITH  <<04833>>39190000
   THE EXECUTING USER.                                         <<04833>>39195000
                                                               <<04833>>39200000
INPUT:   ONE OF CLASS'INDEX OR CLASS'NAME                      <<04833>>39205000
         IF CLASS'NAME THEN LAST CHARACTER IN STRING SHOULD    <<04833>>39210000
         BE A NON-ALPHANUMERIC.                                <<04833>>39215000
OUTPUT:  TRUE OR FALSE                                         <<04833>>39220000
         ERROR'RETURN SET AN ABNORMAL CONDITIONS.              <<04833>>39225000
**** WARNING: DCT SIR MUST BE LOCKED EXTERNALLY ****           <<07438>>39230000
END COMMENT;                                                   <<04833>>39235000
BEGIN                                                          <<04833>>39240000
INTEGER                                                        <<04833>>39245000
   CLASS'ADDRESS,                                              <<07438>>39250000
   CLASS'LEN,                                                  <<04833>>39255000
   INDEX := -1;                                                <<07438>>39260000
INTEGER ARRAY                                                  <<04833>>39265000
   LCLASS'NAME(0:4),                                           <<04833>>39270000
   GETCLASSBUF(0:4);                                           <<07438>>39275000
BYTE ARRAY                                                     <<04833>>39280000
   LCLASS'NAME'(*) = LCLASS'NAME;                              <<07438>>39285000
LOGICAL POINTER                                                <<07438>>39290000
   DCT;                                                        <<07438>>39295000
LOGICAL                                                        <<04833>>39300000
   PARMASK = Q - 4;                                            <<04833>>39305000
DEFINE                                                         <<04833>>39310000
   INDEX'PRESENT = PARMASK.(13:1)#,                            <<04833>>39315000
   NAME'PRESENT = PARMASK.(14:1)#,                             <<04833>>39320000
   ERROR'PRESENT = PARMASK#;                                   <<04833>>39325000
                                                               <<04833>>39330000
                                                               <<04833>>39335000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07438>>39340000
                                                               <<04833>>39345000
CHECKASS'CLASS := FALSE;                                       <<04833>>39350000
IF (INDEX'PRESENT LAND NAME'PRESENT) OR                        <<04833>>39355000
   (NOT INDEX'PRESENT LAND NOT NAME'PRESENT) THEN              <<04833>>39360000
   BEGIN                                                       <<04833>>39365000
      IF ERROR'PRESENT THEN                                    <<04833>>39370000
         ERROR'RETURN := 1;                                    <<04833>>39375000
      RETURN;                                                  <<04833>>39380000
   END;                                                        <<04833>>39385000
IF NAME'PRESENT THEN                                           <<04833>>39390000
   BEGIN                                                       <<04833>>39395000
      LCLASS'NAME := "  ";                                     <<04833>>39400000
      MOVE LCLASS'NAME(1) := LCLASS'NAME,(4);                  <<04833>>39405000
      MOVE CLASS'NAME := CLASS'NAME WHILE AN,1;                <<04833>>39410000
      IF (CLASS'LEN := TOS - @CLASS'NAME) > 8 THEN             <<04833>>39415000
         BEGIN                                                 <<04833>>39420000
            IF ERROR'PRESENT THEN                              <<04833>>39425000
               ERROR'RETURN := 2;                              <<04833>>39430000
            RETURN;                                            <<04833>>39435000
         END;                                                  <<04833>>39440000
      MOVE LCLASS'NAME' := CLASS'NAME,(CLASS'LEN);             <<04833>>39445000
      IF NOT GETCLASS (GETCLASSBUF, FALSE,,, LCLASS'NAME) THEN <<07438>>39450000
         BEGIN                                                 <<04833>>39455000
            IF ERROR'PRESENT THEN                              <<04833>>39460000
               ERROR'RETURN := 3;                              <<04833>>39465000
            RETURN;                                            <<04833>>39470000
         END;                                                  <<04833>>39475000
   END                                                         <<04833>>39480000
ELSE GETCLASSBUF(1) := CLASS'INDEX;                            <<07438>>39485000
CLASS'LEN := GET'DEVICE'CLASS (GETCLASSBUF(1), CLASS'ADDRESS); <<07438>>39490000
IF CLASS'LEN = -1 THEN                                         <<07438>>39495000
   BEGIN                                                       <<07438>>39500000
   IF ERROR'PRESENT THEN                                       <<07438>>39505000
      ERROR'RETURN := 3;                                       <<07438>>39510000
   RETURN;                                                     <<07438>>39515000
   END;                                                        <<07438>>39520000
PUSH (S);                                                      <<07438>>39525000
@DCT := TOS + 1;                                               <<07438>>39530000
TOS := CLASS'LEN;                                              <<07438>>39535000
ASSEMBLE (ADDS 0);                                             <<07438>>39540000
MOVEFROMDSEG (DCT, DCT'DST, CLASS'ADDRESS, CLASS'LEN);         <<07438>>39545000
CHECKASS'CLASS := TRUE;                                        <<04833>>39550000
WHILE (INDEX := INDEX + 1) < INTEGER (DCT'NUM'DEVICES) DO      <<07438>>39555000
   IF NOT CHECKASS (DCT(DCT'FIRST'LDEV + INDEX)) THEN          <<07438>>39560000
      CHECKASS'CLASS := FALSE;                                 <<07438>>39565000
END;    << of CHECKASS'CLASS.                               >> <<07438>>39570000
$PAGE "SENDSPOOLERMSG - AWAKE SPOOLER WITH NEW DIRECTIVE"      <<04833>>39575000
$CONTROL SEGMENT=SPOOLCOMS2                                    <<04833>>39580000
                                                                        39585000
<< Note:  Procedure SENDSPOOLERMSG was moved unchanged from >> <<04833>>39590000
<< OPCOMMAND to SPOOLCOMS as part of this enhancement.  Its >> <<04833>>39595000
<< fix number(s) were not changed.                          >> <<04833>>39600000
                                                                        39605000
LOGICAL PROCEDURE SENDSPOOLERMSG(LDEV,DIRECTIVE,SPOOFLING,              39610000
        ARRAYINFO,                                             <<04833>>39615000
        ERRNUM,PARMNUM);                                                39620000
   VALUE LDEV,DIRECTIVE,SPOOFLING;                                      39625000
   INTEGER DIRECTIVE,ERRNUM,PARMNUM;                                    39630000
   LOGICAL LDEV,SPOOFLING;                                              39635000
   LOGICAL ARRAY ARRAYINFO;                                    <<04833>>39640000
   OPTION PRIVILEGED,UNCALLABLE;                                        39645000
BEGIN                                                                   39650000
                                                                        39655000
COMMENT                                                                 39660000
   THIS PROCEDURE IS USED BY ALL OF THE SPOOLING COMMAND EXECUTORS      39665000
   TO SEND THE APPROPRIATE SPOOLER A DIRECTIVE. THE SPOOLER STACK       39670000
   IS LOCATED AND WORD 1 IS USED FOR COMMUNICATION IN THE SPOOLERS      39675000
   GLOBAL DB AREA. BIT  0 ON INDICATES THE SPOOLER IS BUSY WITH         39680000
   ANOTHER REQUEST. BITS 8 THROUGH 12 INDICATE SPOOLREQUESTS WHILE      39685000
   BITS 13 THROUGH 15 INDICATE A FILEREQUEST.                           39690000
   SPOOLREQUEST                       FILEREQUEST                       39695000
     0 = PRIORDIRECTIVE          0= FINISHFILE                          39700000
     1 = QUITSPOOLING            1= DELETEFILE                          39705000
     2 = WAITSPOOLING            2= DEFERFILE                           39710000
     3 = RESUMESPOOLING          3= RELINKFILE                          39715000
   ARRAYINFO CONTAINS INFORMATION FOR                          <<04833>>39720000
      RESUMESPOOL                                              <<04833>>39725000
          ARRAYINFO(0) IS LOGICAL VARIABLE "BACK"              <<04833>>39730000
                       = -1 BACKWARD RESTART                   <<04833>>39735000
                       = 0  FORWARD RESTART                    <<04833>>39740000
          ARRAYINFO(1) IS PAGE COUNT FOR RESTART               <<04833>>39745000
                       = -1 BEGINNING OF FILE                  <<04833>>39750000
          ARRAYINFO(2) IS FILE COUNT FOR RESTART               <<04833>>39755000
                                             ;                          39760000
                                                                        39765000
INTEGER PCBPT;                                                 <<06744>>39770000
LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY - 1);                    <<06744>>39775000
INTEGER LDT'INDEX := 0;                                        <<06744>>39780000
INTEGER LPDT'INDEX;                                            <<06744>>39785000
INTEGER POINTER PCB=SYSPCBINDEX;                               <<06744>>39790000
EQUATE DIRECTIV = 0,                                                    39795000
       DADWAIT = 1;                                                     39800000
                                                                        39805000
LOGICAL RESULT = SENDSPOOLERMSG;                                        39810000
EQUATE SHUT = 0,                                                        39815000
       OPEN = 1,                                               <<04833>>39820000
       UNCHANGED = 2;                                          <<04833>>39825000
EQUATE BACKWARDS=46, <<DB RELATIVE>>                           <<04833>>39830000
       PAGEPTR = 47, <<LOCATIONS IN >>                         <<04833>>39835000
       FILEPTR = 48; <<SPOOLER STACK>>                         <<04833>>39840000
LOGICAL BACK;                                                  <<04833>>39845000
INTEGER PAGES,FILES;                                           <<04833>>39850000
DEFINE PROCDIRECTIVE = DIRECTIVE.(8:4)#;                       <<07438>>39855000
                                                               <<07438>>39860000
                                                               <<07438>>39865000
SUBROUTINE DEF'MOVEFROMDSEG;                                            39870000
SUBROUTINE DEF'MOVETODSEG;                                              39875000
                                                               <<04833>>39880000
LOGICAL SUBROUTINE VALID'LDEV(LDEV);                           <<04833>>39885000
   VALUE LDEV; INTEGER LDEV;                                   <<04833>>39890000
   BEGIN                                                       <<04833>>39895000
                                                               <<04833>>39900000
      VALID'LDEV := FALSE;                                     <<04833>>39905000
      LPDT'INDEX := LDEV * SIZE'OF'LPDT'ENTRY;                 <<06744>>39910000
      IF LDEV < 1 THEN                                         <<04833>>39915000
      BEGIN      <<BAD LOGICAL DEVICE>>                        <<04833>>39920000
         PARMNUM := 1; ERRNUM := EXPLDEVBAD;                   <<04833>>39925000
      END                                                      <<04833>>39930000
      ELSE                                                     <<04833>>39935000
      IF LDEV > INTEGER(LPDT'MAX'ENTRIES) THEN                 <<06744>>39940000
      BEGIN   <<DEVICE NOT IN CONFIGURATION>>                  <<04833>>39945000
         PARMNUM := 1; ERRNUM := LDEVNOTCONFIG;                <<04833>>39950000
      END                                                      <<04833>>39955000
      ELSE                                                     <<04833>>39960000
      IF LPDT'VIRTUAL'DEVICE THEN                              <<06744>>39965000
      BEGIN     <<NOT REAL>>                                   <<04833>>39970000
         PARMNUM := 1; ERRNUM := LDEVNOTREAL;                  <<04833>>39975000
      END                                                      <<04833>>39980000
      ELSE VALID'LDEV := TRUE;                                 <<04833>>39985000
   END; <<SUBROUTINE VALID'LDEV>>                              <<04833>>39990000
                                                               <<04833>>39995000
<<>>                                                           <<04833>>40000000
SENDSPOOLERMSG := FALSE;                                                40005000
BACK := ARRAYINFO;                                             <<04833>>40010000
PAGES := ARRAYINFO(1);                                         <<04833>>40015000
FILES := ARRAYINFO(2);                                         <<04833>>40020000
IF NOT VALID'LDEV(LDEV) THEN RETURN; <<INVALID LDEV>>          <<04833>>40025000
MOVEFROMDSEG( LDT,LDT'DST,LDEV*SIZE'OF'LDT'ENTRY,              <<06744>>40030000
              SIZE'OF'LDT'ENTRY);                              <<06744>>40035000
IF SPOOFLING <> UNCHANGED THEN                                 <<04833>>40040000
LDT'SPOOL'QUEUES := SPOOFLING; <<SHUTQ/OPENQ>>                 <<06744>>40045000
IF LDT'SPOOLER'PIN = 0 OR LDT'SPOOL'STATE =LDT'NOT'SPOOLED THEN<<06744>>40050000
BEGIN  <<DEVICE NOT SPOOLED>>                                  <<04833>>40055000
   PARMNUM := 1; ERRNUM := DEVICENOTSPOOLED;                   <<04833>>40060000
   RETURN;                                                     <<04833>>40065000
END;                                                           <<04833>>40070000
PCBPT := LDT'SPOOLER'PIN * PCBSIZE;                            <<06744>>40075000
EXCHANGEDB(SPCBSTKDST);                                        <<06744>>40080000
IF LOGICAL(DBP(DIRECTIV).(0:1)) THEN                                    40085000
BEGIN     <<SPOOLER BUSY>>                                              40090000
   EXCHANGEDB(0);    <<RETURN TO CI STACK>>                    <<04833>>40095000
   PARMNUM := 1;                                                        40100000
   ERRNUM := SPOOLERBUSY;                                               40105000
END                                                                     40110000
ELSE                                                                    40115000
BEGIN   <<SPOOLER NOT BUSY>>                                            40120000
   DBP(DIRECTIV) := DIRECTIVE;                                          40125000
   IF PROCDIRECTIVE = RESUMESPOOLING THEN                      <<04833>>40130000
   BEGIN                                                       <<04833>>40135000
      DBP(BACKWARDS) := BACK;                                  <<04833>>40140000
      DBP(PAGEPTR) := PAGES;                                   <<04833>>40145000
      DBP(FILEPTR) := FILES;                                   <<04833>>40150000
   END;                                                        <<04833>>40155000
   EXCHANGEDB(0);                                                       40160000
   MOVETODSEG(LDT'DST,LDEV*SIZE'OF'LDT'ENTRY,LDT,              <<06744>>40165000
              SIZE'OF'LDT'ENTRY);                              <<06744>>40170000
   AWAKE(PCBPT,DADWAIT,0);                                     <<06744>>40175000
   SENDSPOOLERMSG := TRUE;                                              40180000
END;                                                                    40185000
   IF RESULT AND SPOOFLING = OPEN THEN                                  40190000
   BEGIN                                                                40195000
      DISABLE;                                                          40200000
      SYSDEVAVAIL := TRUE;                                     <<07438>>40205000
      ENABLE;                                                           40210000
      AWAKE (SYSUCOPPCB, JUNKWAIT, 0);                         <<07438>>40215000
   END;                                                                 40220000
END;  <<SENDSPOOLERMSG>>                                                40225000
$PAGE "DELETESPOOLFILE EXECUTOR"                               <<04833>>40230000
$CONTROL SEGMENT=SPOOLCOMS2                                    <<04833>>40235000
                                                                        40240000
<< Note:  Procedure CXDELETESPOOLFILE was  moved  unchanged >> <<04833>>40245000
<< from OPCOMMAND to SPOOLCOMS as part of this enhancement. >> <<04833>>40250000
<< Its fix number(s) were not changed.                      >> <<04833>>40255000
                                                                        40260000
PROCEDURE CXDELETESPOOLFILE  EXECUTORHEAD;                              40265000
BEGIN                                                                   40270000
   COMMENT                                                              40275000
      THE SYNTAX OF THIS COMMAND IS:                                    40280000
         DELETESPOOLFILE #ONNN                                          40285000
         DELETESPOOLFILE #INNN                                          40290000
         DELETESPOOLFILE  LDEV                                 <<04833>>40295000
   ;                                                                    40300000
   DOUBLE DL := [8/",", 8/".", 8/";", 8/%15]D;                          40305000
   BYTE ARRAY DL'(*)=DL;                                                40310000
   DOUBLE ARRAY PARM(0:3)=Q;                                            40315000
   BYTE POINTER FIRSTPARM=PARM, SNDPARM=PARM+2;                         40320000
                                                                        40325000
   BYTE FIRSTLEN=PARM+1, SNDLEN=PARM+3;                                 40330000
   INTEGER PARM1=PARM+1, PARM2=PARM+3, PARM3=PARM+5;                    40335000
   INTEGER NUMPARMS, FILENUM, DELETE'RETURN := 0;              <<07438>>40340000
   EQUATE COMMA=0, PERIOD=1, SEMICOLON=2;                               40345000
   LOGICAL OUT;                                                         40350000
   INTEGER DFID,XDDEP;                                         <<06744>>40355000
   INTEGER SAVELDT, SAVEXDD;                                   <<07438>>40360000
   LOGICAL ARRAY XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY)=Q;       <<07062>>40365000
   LOGICAL FIND;                                                        40370000
   LOGICAL LDEV'SPECIFIED := FALSE;                            <<04833>>40375000
   INTEGER LDEV;                                               <<04833>>40380000
   INTEGER LDT'INDEX := 0;                                     <<06744>>40385000
   INTEGER LPDT'INDEX;                                         <<06744>>40390000
   <<CI/SPOOLER DIRECTIVE>>                                    <<04833>>40395000
   EQUATE NODIRECTIVE = %100000;                               <<04833>>40400000
   INTEGER NEWDIRECTIVE := NODIRECTIVE;                        <<04833>>40405000
   DEFINE PROCDIRECTIVE = NEWDIRECTIVE.(8:4)#,                 <<04833>>40410000
          FILEDIRECTIVE = NEWDIRECTIVE.(12:4)#;                <<04833>>40415000
   LOGICAL ARRAY SPOOLINFO(0:3);                               <<04833>>40420000
   INTEGER XDD'DST, XDD'SIR;                                   <<07438>>40425000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY-1);                   <<06744>>40430000
   INTEGER SPOOFLING;                                          <<04833>>40435000
   EQUATE SHUT = 0,                                            <<04833>>40440000
          OPEN = 1,                                            <<04833>>40445000
          UNCHANGED = 2;                                       <<04833>>40450000
                                                               <<04833>>40455000
   SUBROUTINE DEF'MOVEFROMDSEG;                                         40460000
LOGICAL SUBROUTINE ASS'DFID;                                   <<04833>>40465000
COMMENT                                                        <<04833>>40470000
   SUBROUTINE FINDS OUT IF A PARTICULAR DEVICE FILE ID         <<04833>>40475000
   RESIDES ON A DEVICE OR A DEVICE CLASS WHICH IS ASSOCI-      <<04833>>40480000
   ATED WITH THE USER INVOKING THE COMMAND.                    <<04833>>40485000
                                                               <<04833>>40490000
NOTE:                                                          <<04833>>40495000
   IDD OR ODD SIR ALREADY LOCKED.                              <<04833>>40500000
   WHEN FILE IS NOT FOUND RETURNS TRUE. WILL BE CAUGHT ON      <<04833>>40505000
   SECOND CALL TO SFINDODD OR SFINDIDD.                        <<04833>>40510000
END COMMENT.;                                                  <<04833>>40515000
BEGIN                                                          <<04833>>40520000
   ASS'DFID := FALSE;                                          <<04833>>40525000
   FIND := IF OUT THEN SFINDODD(DFID,XDDEP)                    <<06744>>40530000
                  ELSE SFINDIDD(DFID,XDDEP);                   <<06744>>40535000
   IF NOT FIND THEN                                            <<04833>>40540000
      BEGIN                                                    <<04833>>40545000
         ASS'DFID := TRUE;                                     <<04833>>40550000
         RETURN;                                               <<04833>>40555000
      END;                                                     <<04833>>40560000
   MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST, XDDEP.(1:15),          <<07438>>40565000
                 SIZE'OF'XDD'SUBENTRY);                        <<07438>>40570000
   IF XDDS'CLASS THEN                                          <<06744>>40575000
      BEGIN                                                    <<04833>>40580000
         IF CHECKASS'CLASS(XDDS'DEVICE) THEN                   <<06744>>40585000
            ASS'DFID := TRUE;                                  <<04833>>40590000
      END                                                      <<04833>>40595000
   ELSE                                                        <<04833>>40600000
      BEGIN                                                    <<04833>>40605000
         IF CHECKASS(XDDS'DEVICE) THEN                         <<06744>>40610000
            ASS'DFID := TRUE;                                  <<04833>>40615000
      END;                                                     <<04833>>40620000
END;                                                           <<04833>>40625000
                                                                        40630000
                                                                        40635000
   LOGIMAGE( M'DELETESPOOLFILE, PARMSP );                      <<04833>>40640000
   ERRNUM := 0;                                                         40645000
   MYCOMMAND(PARMSP,DL',2,NUMPARMS,PARM);<<PARSE PARAMETERS>>           40650000
   IF NUMPARMS=0 THEN <<NEED AT LEAST ONE PARAMETER>>                   40655000
   BEGIN                                                                40660000
      PARMNUM:=1;                                                       40665000
      CIERR(ERRNUM:=EXPSPFNAME,PARMSP);                                 40670000
   END                                                                  40675000
   ELSE                                                                 40680000
   IF FIRSTLEN > 0 THEN                                        <<04833>>40685000
      IF NUMPARMS<>1 THEN <<TOO MANY PARMS SPECIFIED>>                  40690000
      BEGIN                                                             40695000
         PARMNUM:=2;                                                    40700000
         CIERR(ERRNUM:=FILENUMNOOTHERP,SNDPARM);                        40705000
      END                                                               40710000
      ELSE <<PARSE FILE NUM>>                                           40715000
         IF FIRSTPARM = "#" THEN <<FILENUM SPECIFIED>>         <<04833>>40720000
         BEGIN                                                 <<04833>>40725000
         IF (FIRSTLEN<3) OR                                             40730000
           (NOT ((FIRSTPARM(1)="O") LOR (FIRSTPARM(1)="I"))) THEN       40735000
         BEGIN                                                          40740000
            PARMNUM:=1;                                                 40745000
            CIERR(ERRNUM:=EXPOORINUM,FIRSTPARM(1));                     40750000
         END                                                            40755000
         ELSE                                                           40760000
         BEGIN                                                          40765000
            FILENUM:=BINARY(FIRSTPARM(2),FIRSTLEN-2);                   40770000
            IF <> OR NOT (1<=FILENUM<=%77777) THEN             <<04833>>40775000
                  << BAD FILE NUMBER >>                        <<04833>>40780000
            BEGIN                                                       40785000
               PARMNUM:=1;                                              40790000
               CIERR(ERRNUM:=BADFILENUM,FIRSTPARM(2));                  40795000
            END;                                                        40800000
         END;                                                  <<04833>>40805000
      END                                                      <<04833>>40810000
     ELSE                                                               40815000
     BEGIN                                                              40820000
        <<ASSUME LOGICAL DEVICE SPECIFIED>>                    <<04833>>40825000
        LDEV'SPECIFIED := TRUE;                                <<04833>>40830000
      LDEV:=VERIFY'RLDEV(FIRSTPARM,FIRSTLEN,ERRNUM,PARMNUM,1); <<04833>>40835000
      IF < THEN RETURN;                                        <<04833>>40840000
      IF VERIFY'MASTEROP(LDEV) THEN RETURN;<<MSTEROP MADE INADV<<04833>>40845000
      IF CHECKASS(LDEV) OR                                     <<04833>>40850000
         CHECKALLOW(M'DELETESPOOLFILE) THEN <<USER HAS ACCESS>><<04833>>40855000
      BEGIN                                                    <<04833>>40860000
      FILEDIRECTIVE := DELETEFILE;                             <<04833>>40865000
      PROCDIRECTIVE := PRIORDIRECTIVE;                         <<04833>>40870000
      SAVELDT := GETSIR (LDT'SIR);                             <<07438>>40875000
      MOVEFROMDSEG(  LDT, LDT'DST, LDEV*SIZE'OF'LDT'ENTRY,     <<06744>>40880000
                     SIZE'OF'LDT'ENTRY);                       <<06744>>40885000
      IF LDT'SPOOL'STATE = LDT'NOT'SPOOLED THEN                <<06744>>40890000
      BEGIN     <<NOT A SPOOLED DEVICE>>                       <<04833>>40895000
         PARMNUM := 1;                                         <<04833>>40900000
         RELSIR (LDT'SIR, SAVELDT);                            <<07438>>40905000
         CIERR(ERRNUM := DEVICENOTSPOOLED,FIRSTPARM);          <<04833>>40910000
         RETURN;                                               <<04833>>40915000
      END                                                      <<04833>>40920000
     ELSE                                                      <<04833>>40925000
        BEGIN                                                  <<07438>>40930000
        SAVEXDD := GETSIR (ODD'SIR);                           <<07438>>40935000
        IF NOT SFINDACTIVE(LDEV,DFID) THEN                     <<07438>>40940000
           BEGIN   <<LDEV IS NOT ACTIVE>>                      <<07438>>40945000
           RELSIR (ODD'SIR, SAVEXDD);                          <<07438>>40950000
           RELSIR (LDT'SIR, SAVELDT);                          <<07438>>40955000
           PARMNUM := 1;                                       <<07438>>40960000
           CIERR (ERRNUM := LDEVNOTACTIVE, FIRSTPARM);         <<07438>>40965000
           RETURN;                                             <<07438>>40970000
           END;                                                <<07438>>40975000
        RELSIR (ODD'SIR, SAVEXDD);                             <<07438>>40980000
        END;                                                   <<07438>>40985000
      SPOOFLING := UNCHANGED; <<LEAVE SPOOL QUEUE >>           <<04833>>40990000
      IF NOT SENDSPOOLERMSG(LDEV,NEWDIRECTIVE,SPOOFLING,       <<04833>>40995000
            SPOOLINFO,                                         <<04833>>41000000
             ERRNUM,PARMNUM) THEN                              <<04833>>41005000
         BEGIN                                                 <<04833>>41010000
         RELSIR (LDT'SIR, SAVELDT);                            <<07438>>41015000
         CIERR(ERRNUM,FIRSTPARM);                              <<04833>>41020000
         RETURN;                                               <<04833>>41025000
         END;                                                  <<04833>>41030000
      RELSIR (LDT'SIR, SAVELDT);                               <<07438>>41035000
   END                                                         <<04833>>41040000
   ELSE                                                        <<04833>>41045000
      BEGIN                                                    <<04833>>41050000
         PARMNUM:=1;                                           <<04833>>41055000
         CIERR(ERRNUM:=USERNOACC2DEV,PARMSP);                  <<04833>>41060000
      END;                                                     <<04833>>41065000
     RETURN; <<COMPLETED LDEV CASE>>                           <<04833>>41070000
 END;  <<LDEV CASE>>                                           <<04833>>41075000
            <<CONTINUATION OF DFID CASE>>                      <<04833>>41080000
   IF ERRNUM<>0 THEN RETURN;                                            41085000
   TOS := FILENUM;                                             <<04833>>41090000
   IF FIRSTPARM(1) = "O" THEN                                  <<04833>>41095000
      BEGIN                                                    <<04833>>41100000
      OUT := TRUE;                                             <<04833>>41105000
      TOS.(0:1) := 1;                                          <<04833>>41110000
      XDD'DST := ODD'DST;                                      <<07438>>41115000
      XDD'SIR := ODD'SIR;                                      <<07438>>41120000
      END                                                      <<04833>>41125000
   ELSE                                                        <<07438>>41130000
      BEGIN                                                    <<07438>>41135000
      OUT := FALSE;                                            <<04833>>41140000
      XDD'DST := IDD'DST;                                      <<07438>>41145000
      XDD'SIR := IDD'SIR;                                      <<07438>>41150000
      END;                                                     <<07438>>41155000
   DFID := TOS;                                                <<04833>>41160000
   SAVELDT := GETSIR(LDT'SIR);                                 <<06744>>41165000
   SAVEXDD := GETSIR (XDD'SIR);                                <<07438>>41170000
   IF NOT CHECKALLOW(M'DELETESPOOLFILE) AND                    <<04833>>41175000
      NOT ASS'DFID THEN                                        <<04833>>41180000
   BEGIN                                                                41185000
   PARMNUM := 0;                                                        41190000
   RELSIR (XDD'SIR, SAVEXDD);                                  <<07438>>41195000
   RELSIR(LDT'SIR,SAVELDT);                                    <<06744>>41200000
   CIERR(ERRNUM := OPCOMMNOTALLOW);                                     41205000
   END                                                                  41210000
   ELSE                                                                 41215000
   BEGIN                                                                41220000
         IF OUT THEN FIND := SFINDODD(DFID,XDDEP)              <<06744>>41225000
            ELSE     FIND := SFINDIDD(DFID,XDDEP);             <<07438>>41230000
         IF NOT FIND THEN                                               41235000
            BEGIN <<NO SUCH FILE>>                             <<04833>>41240000
            ERRNUM := NOSUCHFILE;                              <<04833>>41245000
            RELSIR (XDD'SIR, SAVEXDD);                         <<07438>>41250000
            RELSIR(LDT'SIR,SAVELDT);                           <<06744>>41255000
            END                                                <<04833>>41260000
         ELSE                                                           41265000
         BEGIN                                                          41270000
            MOVEFROMDSEG (XDD'SUBENTRY, XDD'DST, XDDEP.(1:15), <<07438>>41275000
                          SIZE'OF'XDD'SUBENTRY);               <<07438>>41280000
            RELSIR (XDD'SIR, SAVEXDD);                         <<07438>>41285000
            RELSIR(LDT'SIR,SAVELDT);                           <<06744>>41290000
            IF XDDS'SPOOL'STATE=XDDS'ACTIVE THEN<<FILE ACTIVE>><<06744>>41295000
            BEGIN                                                       41300000
                                                               <<07438>>41305000
<< VERIFY'MASTEROP'C is not needed because ACTIVE files are >> <<07438>>41310000
<< always linked to a device chain.                         >> <<07438>>41315000
                                                               <<07438>>41320000
                  IF VERIFY'MASTEROP(XDDS'DEVICE) THEN         <<06744>>41325000
                     DELETE'RETURN := 1                                 41330000
                  ELSE                                                  41335000
                     BEGIN                                              41340000
                     DELETE'RETURN :=                                   41345000
                         DELETEDEVFILE(DFID,FALSE) ;                    41350000
                     IF DELETE'RETURN = 0                               41355000
                        THEN                                            41360000
                        BEGIN                                  <<04833>>41365000
                                                               <<07438>>41370000
<< Why are these tests here? -- ACTIVE devicefiles are nei- >> <<07438>>41375000
<< ther virtual devices nor on the class chain.             >> <<07438>>41380000
                                                               <<07438>>41385000
                           LPDT'INDEX := XDDS'DEVICE *         <<06744>>41390000
                                         SIZE'OF'LPDT'ENTRY;   <<06744>>41395000
                           IF LPDT'VIRTUAL'DEVICE OR           <<06744>>41400000
                              XDDS'CLASS THEN    <<NORMAL>>    <<06744>>41405000
                           ELSE                                <<04833>>41410000
                        CIERR(-SPACTLDEV,FIRSTPARM,%10000,              41415000
                              XDDS'DEVICE)                     <<06744>>41420000
                        END                                    <<04833>>41425000
                        ELSE                                   <<04833>>41430000
                           CIERR(-SPACTLDEVNODEL,,%10000,               41435000
                               XDDS'DEVICE);                   <<06744>>41440000
                     END;                                               41445000
            END                                                         41450000
            ELSE                                                        41455000
               DELETE'RETURN := DELETEDEVFILE(DFID,FALSE);              41460000
         END;                                                           41465000
                                                                        41470000
         IF ERRNUM <> 0 THEN                                            41475000
         BEGIN                                                          41480000
            PARMNUM := 1;                                               41485000
            CIERR(ERRNUM,FIRSTPARM);    <<NOSUCHFILE>>                  41490000
         END;                                                           41495000
         CASE DELETE'RETURN OF                                          41500000
         BEGIN                                                          41505000
            ;                     <<0>>  << No error.       >> <<07438>>41510000
                                                                        41515000
            ;                     <<1>>  << Master operator >> <<07438>>41520000
                                         << left it alone.  >> <<07438>>41525000
            BEGIN                 <<2>>                                 41530000
               PARMNUM := 1;                                            41535000
               CIERR(ERRNUM:=NOSUCHFILE,FIRSTPARM);                     41540000
            END;                                                        41545000
            BEGIN                 <<3>>                                 41550000
               PARMNUM := 1;                                            41555000
               CIERR(ERRNUM:=WRONGSTATE,FIRSTPARM);                     41560000
            END;                                                        41565000
           BEGIN                 << 4 >>                       <<04833>>41570000
             PARMNUM := 1;                                     <<04833>>41575000
             CIERR(ERRNUM:=CANT'DELETE'STDIN,FIRSTPARM);       <<04833>>41580000
           END;                                                <<04833>>41585000
         END;                                                           41590000
   END;                                                                 41595000
END;   << CXDELETESPOOLFILE >>                                 <<04833>>41600000
$PAGE "ALTSPOOLFILE EXECUTOR"                                  <<04833>>41605000
$CONTROL SEGMENT=SPOOLCOMS2                                    <<04833>>41610000
                                                                        41615000
<< Note:  Procedure CXALTSPOOLFILE was moved unchanged from >> <<04833>>41620000
<< OPCOMMAND to SPOOLCOMS as part of this enhancement.  Its >> <<04833>>41625000
<< fix number(s) were not changed.                          >> <<04833>>41630000
                                                                        41635000
PROCEDURE CXALTSPOOLFILE EXECUTORHEAD;                                  41640000
BEGIN                                                                   41645000
   COMMENT                                                     <<04833>>41650000
      THE SYNTAX OF THIS COMMAND IS            ;               <<04833>>41655000
                                                               <<04833>>41660000
<<    ALTSPOOLFILE   { #Onnn } ; [PRI=outputpriority] >>       <<04833>>41665000
<<                   {  ldev1}   [COPIES=numcopies  ] >>       <<04833>>41670000
<<                               [DEV= {ldev2}      ] >>       <<04833>>41675000
<<                               [     {devclass}   ] >>       <<04833>>41680000
<<                               [DEFER             ] >>       <<04833>>41685000
<<                                                           >><<04859>>41690000
<< * Fix information:                                        >><<04859>>41695000
<<   When ;DEV= xxxx is specified, the job's JMAT is updated >><<04859>>41700000
<<   with the new device/device class information.  Also,    >><<04859>>41705000
<<   another sequence is used for obtaining SIRs.  The       >><<04859>>41710000
<<   sequence is JMATSIR, LDTSIR and the ODDSIR              >><<07438>>41715000
<<   when you obtain the SIRs.  You release them in the      >><<07438>>41720000
<<   reverse order:  ODDSIR, LDTSIR, JMATSIR.                >><<07438>>41725000
<<                                                           >><<04859>>41730000
                                                               <<04833>>41735000
   EQUATE COMMA=0, EQUAL=1, SEMICOLON=2;                                41740000
   EQUATE MAXPARMS=8;                                                   41745000
   EQUATE PRIKEY=1,DEVKEY=2,COPYKEY=3,DEFERKEY=4;                       41750000
   DOUBLE ARRAY PARM(0:MAXPARMS)=Q;                                     41755000
   BYTE POINTER FIRSTPARM = PARM, EIGHTHPARM = PARM + 14;      <<07438>>41760000
   BYTE FIRSTLEN = PARM + 1;                                   <<07438>>41765000
   INTEGER PARM1 = PARM + 1;                                   <<07438>>41770000
   LOGICAL CLASS,RELINK,COMMAND'ALLOWED;                       <<04833>>41775000
   LOGICAL PRIFLAG,DEFERFLAG,DEVICE'CLASS;                     <<06744>>41780000
   INTEGER CLASS'ADDRESS, CLASS'LENGTH, DEVICE, NUMDEVS,       <<07438>>41785000
           NUMPARMS, PRI;                                      <<07438>>41790000
   INTEGER SAVE'LDT'SIR, SAVE'DCT'SIR, SAVE'ODD'SIR;           <<07438>>41795000
   INTEGER KEY, COPIES, ROOSTER'PARM, DFID, XDDEP;             <<07438>>41800000
   INTEGER POINTER XDDP = XDDEP;                               <<06744>>41805000
   BYTE POINTER PARMPTR;                                                41810000
   BYTE LEN;                                                   <<07438>>41815000
   INTEGER LASTDEL,CURRDEL;                                             41820000
   INTEGER JMATINX:=0;                                         <<06744>>41825000
   INTEGER ARRAY JMATARR(0:JMATENTRYSIZE-1);                   <<06744>>41830000
   LOGICAL ARRAY XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY);         <<06744>>41835000
   BYTE    ARRAY XDD'BSUBENTRY(*) = XDD'SUBENTRY;              <<F7898>>41840000
   LOGICAL ARRAY GETCLASSBUF(0:4);                             <<07438>>41845000
   LOGICAL POINTER DCT;                                        <<07438>>41850000
   INTEGER ARRAY CLASSNAME(0:4);                               <<04833>>41855000
   BYTE ARRAY B'CLASSNAME(*) = CLASSNAME;                      <<07438>>41860000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY - 1);                 <<07438>>41865000
   LOGICAL ARRAY SPOOLINFO(0:3);                               <<04833>>41870000
   INTEGER LDT'INDEX := 0;                                     <<06744>>41875000
   LOGICAL LDEV1, ALTER'LDEV;                                  <<07438>>41880000
   EQUATE <<DIRECTION>>                                        <<04833>>41885000
          IN=0,                                                <<04833>>41890000
          OUT=3, <<SPOOFLING ON + OUTPUT SPOOLING>>            <<04833>>41895000
          EITHER = -1;                                         <<04833>>41900000
   INTEGER DIRECTION := EITHER;                                <<04833>>41905000
INTEGER SAVE'JMAT'SIR, SAVE'2ND'JMAT, JOB'NUMBER, JMAT'DSTP;   <<F7898>>41910000
EQUATE NO'JMAT = 102;  << Msg num in $SET 27, internal errs >> <<F7898>>41915000
   LOGICAL LJOBTYPEJOB;                                        <<07438>>41920000
   <<CI/SPOOLER DIRECTIVE>>                                    <<04833>>41925000
   EQUATE NODIRECTIVE = %100000;                               <<04833>>41930000
   INTEGER NEWDIRECTIVE := NODIRECTIVE;                        <<04833>>41935000
   DEFINE PROCDIRECTIVE = NEWDIRECTIVE.(8:4)#,                 <<04833>>41940000
          ALTER'DEV     = NEWDIRECTIVE.(1:1)#,                 <<04833>>41945000
          FILEDIRECTIVE = NEWDIRECTIVE.(12:4)#;                <<04833>>41950000
   INTEGER SPOOFLING;                                          <<04833>>41955000
   EQUATE SHUT = 0,                                            <<04833>>41960000
          OPEN = 1,                                            <<04833>>41965000
          UNCHANGED = 2;                                       <<04833>>41970000
   LOGICAL WAKE'SPOOLER;  << The Spooler of ACTIVE Device  >>  <<04833>>41975000
                          << Files needs to be informed of >>  <<04833>>41980000
                          << changes to the Device File    >>  <<04833>>41985000
                          << only if the File is DEFERred  >>  <<04833>>41990000
                          << or if its DEV has changed.    >>  <<04833>>41995000
                                                               <<04833>>42000000
                                                               <<04833>>42005000
   SUBROUTINE DEF'MOVEFROMDSEG;                                         42010000
   SUBROUTINE DEF'MOVETODSEG;                                           42015000
   LOGICAL SUBROUTINE GETNEXT;                                          42020000
   BEGIN                                                                42025000
      PARMNUM:=PARMNUM+1;                                               42030000
      IF PARMNUM<NUMPARMS THEN                                          42035000
      BEGIN                                                             42040000
         GETNEXT:=TRUE;                                                 42045000
         LASTDEL:=CURRDEL;                                              42050000
         TOS:=PARM(PARMNUM);                                            42055000
         CURRDEL:=S0.DELIMITER;                                         42060000
         LEN:=TOS&LSR(8);                                               42065000
         @PARMPTR:=TOS;                                                 42070000
      END ELSE GETNEXT:=FALSE;                                          42075000
   END;                                                                 42080000
                                                               <<04859>>42085000
$PAGE                                                          <<F7898>>42090000
<< This subroutine is called when the outclass for a job is  >><<04859>>42095000
<< modified.  This subroutine will update the JMAT for the   >><<04859>>42100000
<< job with the modified JLIST                               >><<04859>>42105000
<< This routine is only called if the output spoolfile is    >><<04859>>42110000
<< still opened.  That is the job is still executing.        >><<04859>>42115000
SUBROUTINE UPDATE'JMAT;                                        <<07438>>42120000
BEGIN                                                          <<04859>>42125000
LJOBTYPEJOB:=TRUE; << YES...WE DO WANT A JOB >>                <<04859>>42130000
                                                               <<F7898>>42135000
<< FINDJOB scans the JMAT trying to  match  JBNMBR.  If  it >> <<F7898>>42140000
<< succeeds,  it returns TRUE with the JMAT SIR (re)locked, >> <<F7898>>42145000
<< the matching entry in  JMATENTRY,  and  a  JMAT-relative >> <<F7898>>42150000
<< offset to the entry in JMAT'DSTP. If FINDJOB can't match >> <<F7898>>42155000
<< JBNMBR it releases its JMAT SIR (we still hold ours) and >> <<F7898>>42160000
<< returns FALSE.  This should never happen, since  it  im- >> <<F7898>>42165000
<< plies  a  mismatch between the ODD (where we got JBNMBR) >> <<F7898>>42170000
<< and the JMAT.  Therefore if it does happen,  we  display >> <<F7898>>42175000
<< a system internal error and ask for the user's screen.   >> <<F7898>>42180000
<<   Note:  We must provide a second cell  for  FINDJOB  to >> <<F7898>>42185000
<< save  its  JMAT  SIR  from GETSIR, since GETSIR does not >> <<F7898>>42190000
<< manage its own acquisition count.                        >> <<F7898>>42195000
                                                               <<F7898>>42200000
IF FINDJOB (JMATARR, JMAT'DSTP, JOB'NUMBER, LJOBTYPEJOB, , , , <<F7898>>42205000
            SAVE'2ND'JMAT) THEN                                <<F7898>>42210000
   BEGIN   << Found entry, update its JLIST.                >> <<F7898>>42215000
   JMATCBIT := CLASS;   << Set device class/ldev bit.       >> <<F7898>>42220000
   IF CLASS THEN                                               <<F7898>>42225000
      JMATORIGJLIST := DEVICE                                  <<F7898>>42230000
   ELSE JMATJLISTDEV := DEVICE;                                <<F7898>>42235000
                                                               <<F7898>>42240000
<< Write the updated JMATENTRY back to the JMAT >>             <<04859>>42245000
                                                               <<F7898>>42250000
   MOVETODSEG (JMATDST, JMAT'DSTP, JMATARR, JMATENTRYSIZE);    <<F7898>>42255000
   RELSIR (JMATSIR, SAVE'2ND'JMAT);                            <<F7898>>42260000
   END     << Found entry, update its JLIST.                >> <<F7898>>42265000
ELSE SYSINTERR (NO'JMAT, -2);   << No JMAT entry?           >> <<F7898>>42270000
END; << UPDATE'JMAT >>                                         <<07438>>42275000
$PAGE                                                          <<F7898>>42280000
LOGICAL SUBROUTINE ASS'DFID;                                   <<04833>>42285000
COMMENT                                                        <<04833>>42290000
   SUBROUTINE FINDS OUT IF A PARTICULAR DEVICE FILE ID         <<04833>>42295000
   RESIDES ON A DEVICE OR DEVICE CLASS WHICH IS ASSOCI-        <<04833>>42300000
   ATED WITH THE USER INVOKING THE COMMAND.                    <<04833>>42305000
                                                               <<04833>>42310000
NOTE:                                                          <<04833>>42315000
   LDT AND ODD SIRS ALREADY ACQUIRED WHEN ASS'DFID IS          <<07438>>42320000
   CALLED.                                                     <<04833>>42325000
   WHEN FILE IS NOT FOUND TRUE IS RETURNED.THE ERROR           <<04833>>42330000
   WILL BE CAUGHT ON THE SECOND CALL TO SFINDODD.              <<04833>>42335000
END COMMENT.;                                                  <<04833>>42340000
BEGIN                                                          <<04833>>42345000
   ASS'DFID := TRUE;                                           <<07438>>42350000
   IF NOT SFINDODD (DFID, XDDEP) THEN RETURN;                  <<07438>>42355000
   MOVEFROMDSEG( XDD'SUBENTRY, ODD'DST, XDDEP.(1:15),          <<06744>>42360000
                 SIZE'OF'XDD'SUBENTRY);                        <<06744>>42365000
   IF XDDS'CLASS THEN                                          <<06744>>42370000
      IF CHECKASS'CLASS (XDDS'DEVICE) THEN RETURN              <<07438>>42375000
      ELSE                                                     <<07438>>42380000
   ELSE                                                        <<04833>>42385000
      IF CHECKASS (XDDS'DEVICE) THEN RETURN;                   <<07438>>42390000
   ASS'DFID := FALSE;   << You lose!                        >> <<07438>>42395000
END;    << of ASS'DFID.                                     >> <<07438>>42400000
$PAGE                                                                   42405000
<<***********************************************************>><<04859>>42410000
<<      START OF MAIN BODY OF EXECUTOR                       >><<04859>>42415000
<<                                                           >><<04859>>42420000
<< NOTE:  JMAT is now updated when a ";DEV=nn" is specifed   >><<04859>>42425000
   LOGIMAGE( M'ALTSPOOLFILE, PARMSP );  << LOG OP COMMAND >>   <<04833>>42430000
   ERRNUM := 0;                                                         42435000
   PARMNUM := 0;                                                        42440000
   ALTER'LDEV := FALSE;                                        <<04833>>42445000
   WAKE'SPOOLER := FALSE;                                      <<04833>>42450000
   PRI := -1;                                                           42455000
   COPIES := DEVICE := 0;                                               42460000
   RELINK := FALSE;                                                     42465000
   CLASS := FALSE;                                                      42470000
   PRIFLAG := DEFERFLAG := FALSE;                                       42475000
   COMMAND'ALLOWED := CHECKALLOW(M'ALTSPOOLFILE);              <<04833>>42480000
   MYCOMMAND(PARMSP,,MAXPARMS,NUMPARMS,PARM); <<PARSE PARMS>>           42485000
   IF > THEN                                                   <<07438>>42490000
      BEGIN   << Too many parameters.                       >> <<07438>>42495000
      PARMNUM := MAXPARMS;                                     <<07438>>42500000
      CIERR (ERRNUM := EXPOAND1PARM, EIGHTHPARM);              <<07438>>42505000
      END     << Too many parameters.                       >> <<07438>>42510000
   ELSE IF NUMPARMS < 2 THEN                                   <<A7587>>42515000
      BEGIN   << Not enough parameters.                     >> <<07438>>42520000
      ERRNUM := EXPOAND1PARM;                                  <<07438>>42525000
      PARMNUM := NUMPARMS;                                     <<07438>>42530000
      IF NUMPARMS = 0 THEN                                     <<A7587>>42535000
         @PARMPTR := @PARMSP                                   <<A7587>>42540000
      ELSE                                                     <<A7587>>42545000
         BEGIN   << NUMPARMS must be 1.                     >> <<A7587>>42550000
         TOS := PARM;   << PARM(0) has info for 1st parm.   >> <<A7587>>42555000
         DEL;   << We're interested only in address pointer >> <<A7587>>42560000
         @PARMPTR := TOS;                                      <<A7587>>42565000
         END;    << NUMPARMS must be 1.                     >> <<A7587>>42570000
      CIERR (ERRNUM, PARMPTR);                                 <<A7587>>42575000
      END     << Not enough parameters.                     >> <<07438>>42580000
   ELSE                                                                 42585000
      BEGIN   << Legal number of parameters.                >> <<07438>>42590000
      IF FIRSTPARM <> "#O" THEN                                <<07438>>42595000
         BEGIN   << :ALTSPOOLFILE {ldev1};...               >> <<07438>>42600000
         LDEV1 := VERIFY'RLDEV (FIRSTPARM, FIRSTLEN,           <<07438>>42605000
                               ERRNUM, PARMNUM, 1);            <<07438>>42610000
         IF < THEN                                             <<07438>>42615000
            ERRNUM := EXPONUM   << Virt or non-config LDEV. >> <<07438>>42620000
         ELSE                                                  <<07438>>42625000
            BEGIN   << Is device spoolable/spooled?         >> <<07438>>42630000
            MOVEFROMDSEG (LDT, LDT'DST, LDEV1 *                <<07438>>42635000
               SIZE'OF'LDT'ENTRY, SIZE'OF'LDT'ENTRY);          <<07438>>42640000
            IF NOT VALIDSPOOLEE (LDT'DEVICE'TYPE,              <<07438>>42645000
               DIRECTION := OUT) THEN                          <<07438>>42650000
               ERRNUM := DEVTYPENOTSPOOLEE                     <<07438>>42655000
            ELSE IF LDT'SPOOL'STATE <> LDT'OUTPUT'SPOOLED THEN <<07438>>42660000
               ERRNUM := DEVICENOTSPOOLED;                     <<07438>>42665000
            END;    << Is device spoolable/spooled?         >> <<07438>>42670000
         IF ERRNUM <> 0 THEN                                   <<07438>>42675000
            BEGIN                                              <<07438>>42680000
            PARMNUM := 1;                                      <<07438>>42685000
            CIERR (ERRNUM, FIRSTPARM);                         <<07438>>42690000
            RETURN;                                            <<07438>>42695000
            END;                                               <<07438>>42700000
         IF VERIFY'MASTEROP (LDEV1) THEN RETURN;               <<07438>>42705000
         IF CHECKASS (LDEV1) OR COMMAND'ALLOWED THEN           <<07438>>42710000
            ALTER'LDEV := TRUE   << User has access.        >> <<07438>>42715000
         ELSE                                                  <<07438>>42720000
            BEGIN   << User not ASSOC or cmnd not allowed.  >> <<07438>>42725000
            PARMNUM := 0;   << No "^" under error message.  >> <<07438>>42730000
            CIERR (ERRNUM := OPCOMMNOTALLOW);                  <<07438>>42735000
            RETURN;                                            <<07438>>42740000
            END;    << User not ASSOC or cmnd not allowed.  >> <<07438>>42745000
         END     << :ALTSPOOLFILE {ldev1};...               >> <<07438>>42750000
      ELSE                                                     <<07438>>42755000
         BEGIN   << :ALTSPOOLFILE #Oxxx;...                 >> <<07438>>42760000
         DFID := BINARY (FIRSTPARM(2), FIRSTLEN - 2);          <<07438>>42765000
         IF <> OR NOT (1 <= DFID <= %77777) THEN               <<07438>>42770000
            BEGIN                                              <<07438>>42775000
            PARMNUM:=1;                                        <<07438>>42780000
            CIERR (ERRNUM := BADFILENUM, FIRSTPARM);           <<07438>>42785000
            RETURN;                                            <<07438>>42790000
            END;                                               <<07438>>42795000
         DFID.(0:1) := 1;   << Signifying an output DFID.   >> <<07438>>42800000
         END;    << :ALTSPOOLFILE #Oxxx;...                 >> <<07438>>42805000
      CURRDEL:=PARM1.DELIMITER;                                         42810000
      PARMNUM:=0;                                                       42815000
      WHILE GETNEXT DO <<PROCESS EACH KEY>>                             42820000
         BEGIN                                                 <<07438>>42825000
         IF PARMPTR = "PRI" AND LEN = 3 THEN KEY:=PRIKEY                42830000
         ELSE                                                           42835000
         IF PARMPTR = "DEV" AND LEN = 3 THEN KEY:=DEVKEY                42840000
         ELSE                                                           42845000
         IF PARMPTR = "COPIES" AND LEN = 6 THEN KEY:=COPYKEY            42850000
         ELSE                                                           42855000
         IF PARMPTR = "DEFER" AND LEN = 5 THEN KEY:=DEFERKEY            42860000
         ELSE                                                           42865000
                                                                        42870000
                                                                        42875000
            BEGIN   << Illegal keyword.                     >> <<07438>>42880000
            CIERR(ERRNUM := EXP1OFKEY,PARMPTR);                         42885000
            RETURN;                                                     42890000
            END;                                               <<07438>>42895000
         IF LASTDEL <> SEMICOLON THEN                          <<07438>>42900000
            BEGIN                                                       42905000
            CIERR (ERRNUM := EXPSEMICOLON, PARMPTR);           <<07438>>42910000
            RETURN;                                            <<07438>>42915000
            END;                                                        42920000
         IF KEY=PRIKEY THEN                                             42925000
            BEGIN   << "PRI", check for prev PRI or DEFER.  >> <<07438>>42930000
            IF PRIFLAG THEN                                             42935000
            CIERR(-PRIOVERPRI,PARMPTR)                                  42940000
            ELSE                                                        42945000
            IF DEFERFLAG THEN                                           42950000
            CIERR(-PRIOVERDEFER,PARMPTR);                               42955000
            DEFERFLAG := FALSE;                                         42960000
            PRIFLAG := TRUE;                                            42965000
            END;                                               <<07438>>42970000
         IF KEY = DEFERKEY THEN                                         42975000
            BEGIN   << "DEFER", check for previous PRI.     >> <<07438>>42980000
            IF PRIFLAG THEN                                             42985000
            CIERR(-DEFEROVERPRI,PARMPTR);                               42990000
            PRIFLAG := FALSE;                                           42995000
            DEFERFLAG := TRUE;                                          43000000
            <<FINISHED FOR DEFER PARSE>>                                43005000
            END                                                <<07438>>43010000
         ELSE                                                           43015000
            BEGIN  << All keywords except DEFER require "=" >> <<07438>>43020000
            IF CURRDEL <> EQUAL THEN                                    43025000
               BEGIN                                           <<07438>>43030000
               CIERR(ERRNUM := EXPEQUALS,PARMPTR);                      43035000
               RETURN;                                                  43040000
               END;                                            <<07438>>43045000
            GETNEXT;   << Get parm after "=".               >> <<07438>>43050000
            END;   << All keywords except DEFER require "=" >> <<07438>>43055000
                                                               <<07438>>43060000
         CASE KEY OF                                                    43065000
         BEGIN                                                          43070000
            <<0>>                                                       43075000
              ;                                                         43080000
                                                               <<07438>>43085000
            <<1>>                                                       43090000
            BEGIN   <<PRIORITY>>                                        43095000
            PRI := BINARY(PARMPTR,LEN);                        <<07438>>43100000
            IF <> OR LEN = 0 OR NOT (0 <= PRI <= 14) THEN      <<07438>>43105000
               BEGIN                                           <<07438>>43110000
               CIERR (ERRNUM := EXPO0TO14, PARMPTR);           <<07438>>43115000
               RETURN;                                         <<07438>>43120000
               END;                                            <<07438>>43125000
            RELINK := TRUE;                                    <<07438>>43130000
            END;                                                        43135000
                                                               <<07438>>43140000
            <<2>>                                                       43145000
            BEGIN                   << DEV = ...            >> <<07438>>43150000
            IF LEN = 0 THEN                                    <<07438>>43155000
               BEGIN                                           <<07438>>43160000
               CIERR (ERRNUM := EXPLDEVORCLASS, PARMPTR);      <<07438>>43165000
               RETURN;                                         <<07438>>43170000
               END;                                            <<07438>>43175000
            DEVICE := BINARY (PARMPTR, LEN);                   <<07438>>43180000
            IF < THEN                                          <<07438>>43185000
               BEGIN   << DEV = classname.                  >> <<07438>>43190000
               CLASS := TRUE;   << For UPDATEJMAT.          >> <<07438>>43195000
               IF LEN > 8 THEN                                 <<07438>>43200000
                  BEGIN   << Classname too long.            >> <<07438>>43205000
                  CIERR (ERRNUM := EXPDEVCLASSLONG, PARMPTR);  <<07438>>43210000
                  RETURN;                                      <<07438>>43215000
                  END;                                         <<07438>>43220000
               CLASSNAME := "  ";                              <<07438>>43225000
               MOVE CLASSNAME(1) := CLASSNAME, (4);            <<07438>>43230000
               MOVE B'CLASSNAME := PARMPTR, (LEN);             <<07438>>43235000
               SAVE'DCT'SIR := GETSIR (DCT'SIR);               <<07438>>43240000
               IF NOT GETCLASS (GETCLASSBUF, FALSE, , ,        <<07438>>43245000
                  CLASSNAME) THEN                              <<07438>>43250000
                  BEGIN                                        <<07438>>43255000
                  RELSIR (DCT'SIR, SAVE'DCT'SIR);              <<07438>>43260000
                  CIERR (ERRNUM := BADCLASSNAME, PARMPTR);     <<07438>>43265000
                  RETURN;                                      <<07438>>43270000
                  END;                                         <<07438>>43275000
               IF VERIFY'MASTOP'C (CLASSNAME) THEN             <<07438>>43280000
                  BEGIN   << Oprat doesn't want to control  >> <<07438>>43285000
                  RELSIR (DCT'SIR, SAVE'DCT'SIR);              <<07438>>43290000
                  RETURN;          << ...ASSOCIATEd device. >> <<07438>>43295000
                  END;                                         <<07438>>43300000
                                                               <<07438>>43305000
<< Is this class ASSOCIATEd to this user?                   >> <<07438>>43310000
                                                               <<07438>>43315000
               IF NOT CHECKASS'CLASS (, B'CLASSNAME) AND       <<07438>>43320000
                  NOT COMMAND'ALLOWED THEN                     <<07438>>43325000
                  BEGIN   << I guess not.                   >> <<07438>>43330000
                  RELSIR (DCT'SIR, SAVE'DCT'SIR);              <<07438>>43335000
                  CIERR (ERRNUM := USERNOACC2CLASS, PARMPTR);  <<07438>>43340000
                  RETURN;                                      <<07438>>43345000
                  END;                                         <<07438>>43350000
               DEVICE := GETCLASSBUF(1);   << DCT index.    >> <<07438>>43355000
               CLASS'LENGTH := GET'DEVICE'CLASS                <<07438>>43360000
                  (DEVICE, CLASS'ADDRESS);                     <<07438>>43365000
                                                               <<07438>>43370000
<< Build space for DCT entry on stack to check VALIDSPOOLEE >> <<07438>>43375000
                                                               <<07438>>43380000
               PUSH (S);                                       <<07438>>43385000
               @DCT := TOS + 1;                                <<07438>>43390000
               TOS := CLASS'LENGTH;                            <<07438>>43395000
               ASSEMBLE (ADDS 0);                              <<07438>>43400000
               MOVEFROMDSEG (DCT, DCT'DST, CLASS'ADDRESS,      <<07438>>43405000
                             CLASS'LENGTH);                    <<07438>>43410000
                                                               <<07438>>43415000
<< Valid spoolee if any device in class is valid.           >> <<07438>>43420000
                                                               <<07438>>43425000
               NUMDEVS := DCT'NUM'DEVICES - 1;                 <<07438>>43430000
               DIRECTION := OUT;                               <<07438>>43435000
               DO BEGIN   << Don't need LDT SIR for devtype >> <<07438>>43440000
                  MOVEFROMDSEG (LDT, LDT'DST,                  <<07438>>43445000
                     DCT(DCT'FIRST'LDEV + NUMDEVS) *           <<07438>>43450000
                     SIZE'OF'LDT'ENTRY, SIZE'OF'LDT'ENTRY);    <<07438>>43455000
                  END                                          <<07438>>43460000
                 UNTIL VALIDSPOOLEE (LDT'DEVICE'TYPE,          <<07438>>43465000
                                     DIRECTION)                <<07438>>43470000
                    OR (NUMDEVS := NUMDEVS - 1) < 0;           <<07438>>43475000
               RELSIR (DCT'SIR, SAVE'DCT'SIR);                 <<07438>>43480000
               IF NUMDEVS < 0 THEN                             <<07438>>43485000
                  BEGIN   << No valid spoolee in class.     >> <<07438>>43490000
                  CIERR (ERRNUM := CLTYPENOTSPOOLEE, PARMPTR); <<07438>>43495000
                  RETURN;                                      <<07438>>43500000
                  END;                                         <<07438>>43505000
               END     << DEV = classname.                  >> <<07438>>43510000
            ELSE                                               <<07438>>43515000
               BEGIN   << DEV = ldev.                       >> <<07438>>43520000
               DEVICE := VERIFY'RLDEV (PARMPTR, LEN, ERRNUM,   <<07438>>43525000
                                      PARMNUM, 1);             <<07438>>43530000
               IF < THEN RETURN;                               <<07438>>43535000
               CLASS := FALSE;   << For UPDATE'JMAT.        >> <<07438>>43540000
               IF VERIFY'MASTEROP (DEVICE) THEN RETURN;        <<07438>>43545000
               IF NOT CHECKASS (DEVICE) AND                    <<07438>>43550000
                  NOT COMMAND'ALLOWED THEN                     <<07438>>43555000
                  BEGIN                                        <<07438>>43560000
                  CIERR (ERRNUM := USERNOACC2DEV, PARMPTR);    <<07438>>43565000
                  RETURN;                                      <<07438>>43570000
                  END;                                         <<07438>>43575000
               DIRECTION := OUT;                               <<V8738>>43580000
               MOVEFROMDSEG (LDT, LDT'DST, DEVICE *            <<V8738>>43585000
                  SIZE'OF'LDT'ENTRY, SIZE'OF'LDT'ENTRY);       <<V8738>>43590000
               IF NOT VALIDSPOOLEE (LDT'DEVICE'TYPE,           <<V8738>>43595000
                                    DIRECTION) THEN            <<V8738>>43600000
                  BEGIN   << Device is not a valid spoolee. >> <<V8738>>43605000
                  CIERR (ERRNUM := DEVTYPENOTSPOOLEE, PARMPTR);<<V8738>>43610000
                  RETURN;                                      <<V8738>>43615000
                  END;    << Device is not a valid spoolee. >> <<V8738>>43620000
               END;    << DEV = ldev.                       >> <<07438>>43625000
            ALTER'DEV := TRUE;   << So spooler won't relink >> <<07438>>43630000
            RELINK := TRUE;                                             43635000
            WAKE'SPOOLER := TRUE;                              <<07438>>43640000
            END;                 << DEV = ...               >> <<07438>>43645000
                                                               <<07438>>43650000
            <<3>>                                                       43655000
            BEGIN                << COPIES = ...            >> <<07438>>43660000
            COPIES := BINARY(PARMPTR,LEN);                     <<07438>>43665000
            IF <> OR LEN = 0 OR NOT (1 <= COPIES <= 127) THEN  <<07438>>43670000
               BEGIN                                           <<07438>>43675000
               CIERR (ERRNUM := EXP1TO127, PARMPTR);           <<07438>>43680000
               RETURN;                                         <<07438>>43685000
               END;                                            <<07438>>43690000
            END;                 << COPIES = ...            >> <<07438>>43695000
                                                               <<07438>>43700000
            <<4>>                                                       43705000
            BEGIN                << DEFER                   >> <<07438>>43710000
            PRI := 0;                                          <<07438>>43715000
            RELINK := TRUE;                                    <<07438>>43720000
            WAKE'SPOOLER := TRUE;                              <<04833>>43725000
            END;                 << DEFER                   >> <<07438>>43730000
                                                               <<07438>>43735000
         END;    << End of CASE statement.                  >> <<07438>>43740000
         END;    << Process each key.                       >> <<07438>>43745000
                                                               <<07438>>43750000
      IF ALTER'LDEV THEN                                       <<07438>>43755000
         BEGIN   << :ALTSPOOLFILE {ldev1};... (continued)   >> <<07438>>43760000
         SAVE'LDT'SIR := GETSIR (LDT'SIR);                     <<07438>>43765000
         SAVE'ODD'SIR := GETSIR (ODD'SIR);                     <<07438>>43770000
         IF NOT SFINDACTIVE (LDEV1, DFID) THEN                 <<07438>>43775000
            BEGIN   << LDEV is not active.                  >> <<07438>>43780000
            RELSIR (ODD'SIR, SAVE'ODD'SIR);                    <<07438>>43785000
            RELSIR (LDT'SIR, SAVE'LDT'SIR);                    <<07438>>43790000
            PARMNUM := 1;                                      <<07438>>43795000
            CIERR (ERRNUM := LDEVNOTACTIVE, FIRSTPARM);        <<07438>>43800000
            RETURN;                                            <<07438>>43805000
            END;    << LDEV is not active.                  >> <<07438>>43810000
         RELSIR (ODD'SIR, SAVE'ODD'SIR);                       <<07438>>43815000
         RELSIR (LDT'SIR, SAVE'LDT'SIR);                       <<07438>>43820000
         END;    << :ALTSPOOLFILE {ldev1};... (continued)   >> <<07438>>43825000
                                                               <<04833>>43830000
  COMMENT -- We have parsed all we need to parse, set all  re- <<07438>>43835000
quired flags, and are ready to carry out our orders. There are <<07438>>43840000
a few potential problem areas which future maintainers  should <<07438>>43845000
be  aware of, lest they change something and unwittingly break <<07438>>43850000
it.                                                            <<07438>>43855000
  Whenever we are dealing with an ACTIVE spool file (ldev1 was <<07438>>43860000
specified, or the specified #Oxxx is ACTIVE) AND the user  has <<07438>>43865000
changed  the  target device/class or has DEFERred the file, we <<07438>>43870000
must interrupt (wake) the spooler. The WAKE'SPOOLER flag indi- <<07438>>43875000
cates DEFER or a change in device. Since we run asynchronously <<07438>>43880000
with the spooler, and both processes access the ODD entry  for <<07438>>43885000
the active DFID, a certain amount of co-operation is required. <<07438>>43890000
  If our caller specified a DEV=, we set a flag called  ALTER' <<07438>>43895000
DEV.  This  flag  is passed to the spooler, if we wake it, and <<07438>>43900000
tells it not to relink its file to the class  chain  while  it <<07438>>43905000
cleans up.  Otherwise it might wipe out our DEV change.        <<07438>>43910000
;                                                              <<07438>>43915000
      IF COMMAND'ALLOWED OR ASS'DFID THEN                      <<07438>>43920000
         BEGIN   << User has access to command or device.   >> <<07438>>43925000
         SAVE'JMAT'SIR := GETSIR (JMATSIR);                    <<07438>>43930000
         SAVE'LDT'SIR  := GETSIR (LDT'SIR);                    <<07438>>43935000
         SAVE'ODD'SIR  := GETSIR (ODD'SIR);                    <<07438>>43940000
         IF SFINDODD (DFID, XDDEP) THEN                        <<07438>>43945000
            BEGIN   << Output DFID exists.                  >> <<07438>>43950000
                                                               <<07438>>43955000
<< Clear the high-order bit returned by SFINDODD.           >> <<07438>>43960000
                                                               <<07438>>43965000
            XDDEP.(0:1) := 0;                                  <<07438>>43970000
            MOVEFROMDSEG (XDD'SUBENTRY, ODD'DST, XDDEP,        <<07438>>43975000
                          SIZE'OF'XDD'SUBENTRY);               <<07438>>43980000
            IF XDDS'SPOOFLE'VT'INDEX <> 0 THEN                 <<07438>>43985000
               BEGIN   << And it's a spool file.            >> <<07438>>43990000
               ROOSTER'PARM := 0;  << Wake spoolers if <> 0 >> <<07438>>43995000
               IF COPIES > 0 THEN ODDS'NUMBER'COPIES := COPIES;<<07438>>44000000
               IF PRI >= 0 THEN XDDS'OUTPUT'PRIORITY := PRI;   <<07438>>44005000
               IF DEVICE <> 0 THEN                             <<07438>>44010000
                  BEGIN  << Update device/class, maybe JMAT >> <<07438>>44015000
                  XDDS'DEVICE := DEVICE;                       <<07438>>44020000
                  XDDS'CLASS  := CLASS;                        <<07438>>44025000
                  IF XDDS'SPOOL'STATE = XDDS'OPEN              <<F7898>>44030000
                     AND XDDS'JOB'TYPE = XDDS'JOB              <<F7898>>44035000
                     AND XDDSB'FILE'NAME = "$STDLIST" THEN     <<F7898>>44040000
                     BEGIN   << Update JMAT with new JLIST. >> <<07438>>44045000
                     JOB'NUMBER := XDDS'JOB'NUMBER;            <<07438>>44050000
                     UPDATE'JMAT;                              <<07438>>44055000
                     END;    << Update JMAT with new JLIST. >> <<07438>>44060000
                  END;   << Update device/class, maybe JMAT >> <<07438>>44065000
               MOVETODSEG (ODD'DST, XDDEP, XDD'SUBENTRY,       <<07438>>44070000
                           SIZE'OF'XDD'SUBENTRY);              <<07438>>44075000
               IF RELINK THEN                                  <<07438>>44080000
                  BEGIN   << New device/class or DEFER.     >> <<07438>>44085000
                  IF XDDS'CLASS THEN                           <<07438>>44090000
                     DEVICE'CLASS := -XDDS'DEVICE              <<07438>>44095000
                  ELSE                                         <<07438>>44100000
                     DEVICE'CLASS :=  XDDS'DEVICE;             <<07438>>44105000
                  SRELINKODD (XDDP, DEVICE'CLASS);             <<07438>>44110000
                  ROOSTER'PARM := DEVICE'CLASS;                <<07438>>44115000
                  END;    << New device/class or DEFER.     >> <<07438>>44120000
               END     << And it's a spool file.            >> <<07438>>44125000
            ELSE                                               <<07438>>44130000
               BEGIN   << Not a spool file, hot DFID.       >> <<07438>>44135000
               ERRNUM  := EXPSPFNAME;                          <<07438>>44140000
               PARMNUM := 1;                                   <<07438>>44145000
               END;    << Not a spool file, hot DFID.       >> <<07438>>44150000
            END     << Output DFID exists.                  >> <<07438>>44155000
         ELSE                                                  <<07438>>44160000
            BEGIN   << Non-existent output DFID.            >> <<07438>>44165000
            ERRNUM  := NOSUCHFILE;                             <<07438>>44170000
            PARMNUM := 1;                                      <<07438>>44175000
            END;    << Non-existent output DFID.            >> <<07438>>44180000
         RELSIR (ODD'SIR, SAVE'ODD'SIR);                       <<07438>>44185000
         RELSIR (LDT'SIR, SAVE'LDT'SIR);                       <<07438>>44190000
         RELSIR (JMATSIR, SAVE'JMAT'SIR);                      <<07438>>44195000
         IF ERRNUM = 0 THEN                                    <<07438>>44200000
            BEGIN   << Finish processing if no errors yet.  >> <<07438>>44205000
            IF XDDS'SPOOL'STATE = XDDS'ACTIVE AND WAKE'SPOOLER <<07438>>44210000
               THEN                                            <<07438>>44215000
               BEGIN   << Must wake current device spooler. >> <<07438>>44220000
               DIRECTION := OUT;                               <<07438>>44225000
               PROCDIRECTIVE := PRIORDIRECTIVE;                <<07438>>44230000
               FILEDIRECTIVE := RELINKFILE;                    <<07438>>44235000
               SPOOFLING := UNCHANGED;                         <<07438>>44240000
               SAVE'LDT'SIR := GETSIR (LDT'SIR);               <<07438>>44245000
               IF NOT SENDSPOOLERMSG (XDDS'DEVICE,             <<07438>>44250000
                  NEWDIRECTIVE, SPOOFLING, SPOOLINFO, ERRNUM,  <<07438>>44255000
                  PARMNUM) THEN                                <<07438>>44260000
                  BEGIN   << Spooler not responding, busy.  >> <<07438>>44265000
                  RELSIR (LDT'SIR, SAVE'LDT'SIR);              <<07438>>44270000
                  CIERR (ERRNUM, FIRSTPARM);                   <<07438>>44275000
                  RETURN;                                      <<07438>>44280000
                  END     << Spooler not responding, busy.  >> <<07438>>44285000
               ELSE RELSIR (LDT'SIR, SAVE'LDT'SIR);            <<07438>>44290000
               END;    << Must wake current device spooler. >> <<07438>>44295000
            IF ROOSTER'PARM <> 0 THEN SROOSTER (ROOSTER'PARM); <<07438>>44300000
            END     << Finish processing if no errors yet.  >> <<07438>>44305000
         ELSE       << Error of some kind while processing. >> <<07438>>44310000
            CIERR (ERRNUM, FIRSTPARM);                         <<07438>>44315000
         END     << User has access to command or device.   >> <<07438>>44320000
      ELSE                                                     <<07438>>44325000
         BEGIN   << User not ASSOC or command not allowed.  >> <<07438>>44330000
         PARMNUM := 0;   << No "^" under error message.     >> <<07438>>44335000
         CIERR (ERRNUM := OPCOMMNOTALLOW);                     <<07438>>44340000
         END;    << User not ASSOC or command not allowed.  >> <<07438>>44345000
      END;    << Legal number of parameters.                >> <<07438>>44350000
   END;    << of CXALTSPOOLFILE.                            >> <<07438>>44355000
$PAGE "STARTSPOOL EXECUTOR"                                    <<04833>>44360000
$CONTROL SEGMENT=SPOOLCOMS2                                    <<04833>>44365000
                                                                        44370000
<< Note:  Procedure CXSTARTSPOOL was moved  unchanged  from >> <<04833>>44375000
<< OPCOMMAND to SPOOLCOMS as part of this enhancement.  Its >> <<04833>>44380000
<< fix number(s) were not changed.                          >> <<04833>>44385000
                                                                        44390000
PROCEDURE CXSTARTSPOOL EXECUTORHEAD;                                    44395000
BEGIN                                                                   44400000
<<                                                                      44405000
   COMMENT                                                              44410000
      THE SYNTAX OF THIS COMMAND IS:                                    44415000
         STARTSPOOL {ldev     } [;SHUTQ]                                44420000
                    {deviceclass}                                       44425000
         WHERE ldev IS ANY REAL LOGICAL DEVICE                          44430000
   ;                                                                    44435000
>>                                                                      44440000
   DOUBLE DL := [8/",", 8/";", 8/%15, 8/0]D;                            44445000
   BYTE ARRAY DL'(*)=DL;                                                44450000
   DOUBLE ARRAY PARM(0:1)=Q;                                            44455000
   BYTE POINTER FIRSTPARM=PARM, SNDPARM=PARM+2, TRDPARM = PARM+4;       44460000
   BYTE LEN=PARM+1,LEN2 = PARM+3;                              <<04833>>44465000
   INTEGER PARM1 = PARM+1, PARM2=PARM+3;                       <<04833>>44470000
   EQUATE COMMA = 0, SEMICOLON = 1;                            <<04833>>44475000
   LOGICAL OPENQ := TRUE;                                      <<04833>>44480000
   LOGICAL LDEV;                                                        44485000
                                                               <<04833>>44490000
   INTEGER NUMPARMS;                                                    44495000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY - 1);                 <<07438>>44500000
   INTEGER LDT'INDEX := 0;                                     <<07438>>44505000
   EQUATE <<DIRECTION>>                                                 44510000
          IN=0,                                                         44515000
          OUT=1, << OUTPUT SPOOLING>>                                   44520000
          EITHER = -1;                                                  44525000
   INTEGER DIRECTION := EITHER;                                         44530000
   DEFINE SPOOFLING = DIRECTION.(14:1)#; <<OPENQ,SHUTQ>>                44535000
   <<CI/SPOOLER DIRECTIVE>>                                             44540000
   INTEGER SAVE'LDT'SIR, SAVE'DCT'SIR;                         <<07438>>44545000
   INTEGER CLASS'ADDRESS, CLASS'LENGTH, NUMDEVS;               <<07438>>44550000
   LOGICAL ARRAY OFFSET(0:8) = Q;                                       44555000
   BYTE ARRAY BOFFSET(*) = OFFSET;                                      44560000
   INTEGER INITIATE'RESULT;                                             44565000
      INTEGER ARRAY CLASSNAME(0:4);                            <<07438>>44570000
      BYTE ARRAY B'CLASSNAME(*) = CLASSNAME;                   <<04833>>44575000
      INTEGER ARRAY GETCLASSBUF(0:4);                          <<07438>>44580000
   LOGICAL ARRAY SPOOLINFO(0:3);                               <<04833>>44585000
   LOGICAL POINTER DCT;                                        <<06744>>44590000
                                                               <<07438>>44595000
                                                               <<07438>>44600000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<07438>>44605000
SUBROUTINE DEF'MOVETODSEG;                                     <<07438>>44610000
                                                                        44615000
   SUBROUTINE RESETSPSQ;                                                44620000
                                                                        44625000
   BEGIN                                                                44630000
   SAVE'LDT'SIR := GETSIR (LDT'SIR);                           <<07438>>44635000
   LDT'SPOOL'STATE := LDT'NOT'SPOOLED;                         <<07438>>44640000
   LDT'SPOOL'QUEUES := LDT'QSHUT;                              <<07438>>44645000
   MOVETODSEG (LDT'DST, LDEV * SIZE'OF'LDT'ENTRY, LDT,         <<07438>>44650000
               SIZE'OF'LDT'ENTRY);                             <<07438>>44655000
   RELSIR (LDT'SIR, SAVE'LDT'SIR);                             <<07438>>44660000
   END;    <<RESETSPSQ>>                                                44665000
                                                                        44670000
                                                                        44675000
   SUBROUTINE TELL'UCOP;                                       <<04833>>44680000
   <<AWAKE UCOP PIN BY SETTING JOBSYNC FLAG>>                  <<04833>>44685000
   <<ANY JOBS IN QUEUE WAITING FOR THIS CLASS OR DEVICE >>     <<04833>>44690000
   <<CAN THEN EXECUTE>>                                        <<04833>>44695000
                                                               <<04833>>44700000
   BEGIN                                                       <<04833>>44705000
   DISABLE;                                                    <<07438>>44710000
   SYSDEVAVAIL := TRUE;                                        <<07438>>44715000
   ENABLE;                                                     <<07438>>44720000
   AWAKE (SYSUCOPPCB, JUNKWAIT, 0);                            <<07438>>44725000
   END; <<TELL'UCOP>>                                          <<04833>>44730000
                                                                        44735000
                                                                        44740000
   MYCOMMAND(PARMSP,DL',3,NUMPARMS,PARM);                      <<04833>>44745000
   ERRNUM := PARMNUM := 0;                                     <<04833>>44750000
   IF NUMPARMS = 0 THEN <<MUST HAVE AT LEAST 1 PARM>>          <<04833>>44755000
   BEGIN                                                       <<04833>>44760000
      CIERR(ERRNUM := -EXP1OFLDEVORSHUTQ,PARMSP);              <<04833>>44765000
      RETURN;                                                  <<04833>>44770000
   END                                                         <<04833>>44775000
   ELSE                                                        <<04833>>44780000
   IF LEN=0 THEN                                               <<04833>>44785000
   BEGIN                                                       <<04833>>44790000
      PARMNUM := 1;                                            <<04833>>44795000
      CIERR(ERRNUM := EXPLDEVBAD,FIRSTPARM);                   <<04833>>44800000
      RETURN;                                                  <<04833>>44805000
   END                                                         <<04833>>44810000
   ELSE                                                        <<04833>>44815000
   IF NUMPARMS > 2 THEN                                        <<04833>>44820000
   BEGIN                                                       <<04833>>44825000
      PARMNUM := 2;                                            <<04833>>44830000
      CIERR(ERRNUM := STARTSP2PARM,TRDPARM);                   <<04833>>44835000
      RETURN;                                                  <<04833>>44840000
   END;                                                        <<04833>>44845000
   IF NUMPARMS = 2 THEN <<MAXIMUM NUMBER OF PARMS>>            <<04833>>44850000
   BEGIN                                                       <<04833>>44855000
      IF PARM1.DELIMITER <> SEMICOLON THEN                     <<04833>>44860000
      <<MUST HAVE SEMICOLON SEPARATION>>                       <<04833>>44865000
      BEGIN                                                    <<04833>>44870000
         PARMNUM := 2;                                         <<04833>>44875000
         CIERR(ERRNUM := EXPSEMICOLON,FIRSTPARM(LEN));         <<04833>>44880000
      END                                                      <<04833>>44885000
      ELSE                                                     <<04833>>44890000
         <<IS SHUTQ SPECIFIED?>>                               <<04833>>44895000
      BEGIN                                                    <<04833>>44900000
         IF LEN2 <> 5 OR SNDPARM <> "SHUTQ" THEN             <<SP.36>>  44905000
         BEGIN                                                 <<04833>>44910000
            PARMNUM := 2;                                      <<04833>>44915000
            CIERR(ERRNUM := EXPSHUTQ,SNDPARM);                 <<04833>>44920000
            RETURN;                                            <<04833>>44925000
         END                                                   <<04833>>44930000
         ELSE                                                  <<04833>>44935000
         OPENQ := FALSE;                                       <<04833>>44940000
      END;                                                     <<04833>>44945000
   END;                                                        <<04833>>44950000
   IF ERRNUM <> 0 THEN RETURN;                                 <<04833>>44955000
                                                               <<04833>>44960000
                                                               <<04833>>44965000
      LDEV := BINARY(FIRSTPARM,LEN);                           <<04833>>44970000
      IF < THEN                                                <<04833>>44975000
         BEGIN   << :STARTSPOOL {deviceclass}               >> <<07438>>44980000
         IF LEN > 8 THEN                                       <<04833>>44985000
         BEGIN  << CLASSNAME TOO LONG>>                        <<04833>>44990000
            PARMNUM := 1;                                      <<04833>>44995000
            CIERR(ERRNUM := EXPDEVCLASSLONG,FIRSTPARM);        <<04833>>45000000
            RETURN;                                            <<04833>>45005000
         END;                                                  <<04833>>45010000
         <<DETERMINE IF DEVCLASS IS ACCESSIBLE>>               <<04833>>45015000
         CLASSNAME := "  ";                                    <<07438>>45020000
         MOVE CLASSNAME(1) := CLASSNAME, (4);                  <<07438>>45025000
         MOVE B'CLASSNAME := FIRSTPARM, (LEN);                 <<07438>>45030000
         SAVE'DCT'SIR := GETSIR (DCT'SIR);                     <<07438>>45035000
         IF NOT GETCLASS (GETCLASSBUF, FALSE, , , CLASSNAME)   <<07438>>45040000
            THEN                                               <<07438>>45045000
            BEGIN                                              <<07438>>45050000
            RELSIR (DCT'SIR, SAVE'DCT'SIR);                    <<07438>>45055000
            PARMNUM := 1;                                      <<04833>>45060000
            CIERR(ERRNUM := BADCLASSNAME,FIRSTPARM);           <<04833>>45065000
            RETURN;                                            <<04833>>45070000
            END;                                               <<07438>>45075000
         IF VERIFY'MASTOP'C(CLASSNAME) THEN                    <<04833>>45080000
            BEGIN                                              <<04833>>45085000
               RELSIR (DCT'SIR, SAVE'DCT'SIR);                 <<07438>>45090000
               RETURN;                                         <<04833>>45095000
            END;                                               <<04833>>45100000
         << IS REQUESTOR ASSOCIATOR OF THIS CLASS?>>           <<04833>>45105000
         IF CHECKASS'CLASS(,B'CLASSNAME) OR                    <<04833>>45110000
            CHECKALLOW(M'STARTSPOOL) THEN                      <<04833>>45115000
         <<USER HAS ACCESS>>                                   <<04833>>45120000
         ELSE                                                  <<04833>>45125000
         BEGIN                                                 <<04833>>45130000
            PARMNUM := 1;                                      <<04833>>45135000
            RELSIR (DCT'SIR, SAVE'DCT'SIR);                    <<07438>>45140000
            CIERR(ERRNUM := USERNOACC2CLASS,PARMSP);           <<04833>>45145000
            RETURN;                                            <<04833>>45150000
         END;                                                  <<04833>>45155000
                                                               <<04833>>45160000
         <<USER HAS ACCESS>>                                   <<04833>>45165000
         << TO CLASS      >>                                   <<04833>>45170000
         CLASS'LENGTH := GET'DEVICE'CLASS (GETCLASSBUF(1),     <<07438>>45175000
                                           CLASS'ADDRESS);     <<07438>>45180000
         PUSH (S);   << Build DCT entry on stack.           >> <<07438>>45185000
         @DCT := TOS + 1;                                      <<07438>>45190000
         TOS := CLASS'LENGTH;                                  <<07438>>45195000
         ASSEMBLE (ADDS 0);                                    <<07438>>45200000
         MOVEFROMDSEG (DCT, DCT'DST, CLASS'ADDRESS,            <<07438>>45205000
                       CLASS'LENGTH);                          <<07438>>45210000
         IF DCT'SPOOL'QUEUES = DCT'OPEN THEN                   <<07438>>45215000
         BEGIN  <<DEVICECLASS ALREADY SPOOLED>>                <<04833>>45220000
            PARMNUM := 1;                                      <<04833>>45225000
            RELSIR (DCT'SIR, SAVE'DCT'SIR);                    <<07438>>45230000
            CIERR(ERRNUM := CLASSALREADYSPOOLED,FIRSTPARM);    <<04833>>45235000
            RETURN;                                            <<04833>>45240000
         END;                                                  <<04833>>45245000
                                                               <<04833>>45250000
<< Valid spoolee if any device in class is valid.           >> <<07438>>45255000
                                                               <<07438>>45260000
         NUMDEVS := DCT'NUM'DEVICES - 1;                       <<07438>>45265000
         DIRECTION := OUT;                                     <<07438>>45270000
         DO BEGIN   << Don't need LDT'SIR to fetch DEVTYPE. >> <<07438>>45275000
            MOVEFROMDSEG (LDT, LDT'DST, DCT(DCT'FIRST'LDEV     <<07438>>45280000
               + NUMDEVS) * SIZE'OF'LDT'ENTRY,                 <<07438>>45285000
               SIZE'OF'LDT'ENTRY);                             <<07438>>45290000
            END                                                <<07438>>45295000
           UNTIL VALIDSPOOLEE (LDT'DEVICE'TYPE, DIRECTION)     <<07438>>45300000
                 OR (NUMDEVS := NUMDEVS - 1) < 0;              <<07438>>45305000
         IF NUMDEVS < 0 THEN                                   <<07438>>45310000
           BEGIN                                               <<04833>>45315000
              PARMNUM := 1;                                    <<04833>>45320000
              RELSIR (DCT'SIR, SAVE'DCT'SIR);                  <<07438>>45325000
              CIERR(ERRNUM := CLTYPENOTSPOOLEE,FIRSTPARM);     <<04833>>45330000
              RETURN;                                          <<04833>>45335000
           END;                                                <<04833>>45340000
                                                               <<04833>>45345000
         IF NUMPARMS > 1 THEN                                  <<04833>>45350000
         BEGIN  <<CANNOT SPECIFY "SHUTQ" WITH >>               <<04833>>45355000
                <<DEVICECLASS>>                                <<04833>>45360000
            PARMNUM := 2;                                      <<04833>>45365000
            RELSIR (DCT'SIR, SAVE'DCT'SIR);                    <<07438>>45370000
            CIERR(ERRNUM := CLASSXPARMS, SNDPARM);             <<04833>>45375000
            RETURN;                                            <<04833>>45380000
         END;                                                  <<04833>>45385000
         <<NOW WE CAN SET THE SPOOLING BIT IN >>               <<04833>>45390000
         << THE DEVICE CLASS ENTRY>>                           <<04833>>45395000
         DCT'SPOOL'QUEUES := DCT'OPEN;                         <<07438>>45400000
         MOVETODSEG (DCT'DST, CLASS'ADDRESS, DCT,              <<07438>>45405000
                     CLASS'LENGTH);                            <<07438>>45410000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>45415000
                                                               <<07438>>45420000
         <<TELL UCOP THAT QUEUE IS OPEN>>                      <<04833>>45425000
         TELL'UCOP;                                            <<04833>>45430000
         END     << :STARTSPOOL {deviceclass}               >> <<07438>>45435000
      ELSE                                                     <<04833>>45440000
   BEGIN   << :STARTSPOOL {ldev} [;SHUTQ]                   >> <<07438>>45445000
      LDEV:=VERIFY'RLDEV(FIRSTPARM,LEN,ERRNUM,PARMNUM,1);               45450000
      IF < THEN RETURN;                                                 45455000
      IF VERIFY'MASTEROP(LDEV) THEN RETURN;<<MSTEROP MADE INADV. ENTRY>>45460000
      IF CHECKASS(LDEV) OR                                              45465000
         CHECKALLOW(M'STARTSPOOL) THEN <<USER HAS ACCESS>>              45470000
         BEGIN                                                 <<07438>>45475000
         MOVEFROMDSEG (LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY, <<07438>>45480000
                       SIZE'OF'LDT'ENTRY);                     <<07438>>45485000
         IF LDT'DEVICE'TYPE = READERPUNCH THEN                 <<07438>>45490000
         BEGIN    <<DETERMINE IF INPUT OR OUTPUT>>                      45495000
            GENMSG(CIGENERALMSGSET,SPOOLINOROUT,%10000,LDEV,            45500000
                   ,,,,,,,, [1/1, 15/0]);                               45505000
            READX(OFFSET, -3);                                          45510000
            MOVE BOFFSET := BOFFSET WHILE AS;                           45515000
            IF BOFFSET = "IN" THEN DIRECTION := IN                      45520000
               ELSE IF BOFFSET = "OUT" THEN                             45525000
                  DIRECTION := OUT                                      45530000
                     ELSE                                               45535000
                     BEGIN                                              45540000
                        PARMNUM := 0;                                   45545000
                        CIERR(ERRNUM := EXPINOROUT);                    45550000
                        RETURN;                                         45555000
                     END;                                               45560000
         END   <<END OF READER/PUNCH CASE>>                             45565000
         ELSE                                                           45570000
         BEGIN                                                          45575000
            IF NOT VALIDSPOOLEE (LDT'DEVICE'TYPE,              <<07438>>45580000
                                 DIRECTION := OUT)             <<07438>>45585000
               THEN                                            <<06744>>45590000
               IF NOT VALIDSPOOLEE (LDT'DEVICE'TYPE,           <<07438>>45595000
                                    DIRECTION := IN)           <<07438>>45600000
               THEN                                            <<06744>>45605000
               BEGIN                                                    45610000
                  PARMNUM := 1;                                         45615000
                  CIERR(ERRNUM := DEVTYPENOTSPOOLEE,FIRSTPARM);         45620000
                  RETURN;                                               45625000
               END;                                                     45630000
         END;                                                           45635000
                                                                        45640000
         IF DIRECTION = IN AND NUMPARMS > 1 THEN               <<04833>>45645000
         BEGIN  << SHUTQ SPECIFIED FOR INPUT SPOOLEE>>         <<04833>>45650000
            PARMNUM := 2;                                      <<04833>>45655000
            CIERR(ERRNUM := SHUTQINPUT,SNDPARM);               <<04833>>45660000
            RETURN;                                            <<04833>>45665000
         END;                                                  <<04833>>45670000
         <<NOW WE CAN INITIATE SPOOLING>>                               45675000
         IF DIRECTION = OUT THEN <<SET SPOOL QUEUE>>           <<04833>>45680000
         SPOOFLING := OPENQ;<<OPENQ>>                          <<04833>>45685000
         INITIATE'RESULT := INITIATESPOOLER(LDEV,DIRECTION);            45690000
         INITIATE'RESULT := INITIATE'RESULT + 2; <<FOR CASE>>           45695000
         CASE INITIATE'RESULT OF                                        45700000
         BEGIN                                                          45705000
            BEGIN    <<-2>> <<OWNED OUT>>                               45710000
               PARMNUM := 1;                                            45715000
               CIERR(ERRNUM := SPOOLEEOWNEDOUT,FIRSTPARM);              45720000
               RETURN;                                                  45725000
            END;                                                        45730000
            BEGIN    <<-1>>  <<OWNED IN>>                               45735000
               PARMNUM := 1;                                            45740000
               CIERR(ERRNUM := SPOOLEEOWNEDIN,FIRSTPARM);               45745000
               RETURN;                                                  45750000
            END;                                                        45755000
            BEGIN    <<0>>   <<OK>>                                     45760000
               <<OK>>                                                   45765000
               IF OPENQ THEN TELL'UCOP;                        <<04833>>45770000
            END;                                                        45775000
            BEGIN    <<1>>   <<OWNED, NOT SPOOLED>>                     45780000
               PARMNUM := 1;                                            45785000
               CIERR (ERRNUM := DEVOWNEDOTHER, FIRSTPARM);     <<06744>>45790000
               RETURN;                                                  45795000
            END;                                                        45800000
            BEGIN    <<2>>  <<NOT REAL DEVICE>>                         45805000
               PARMNUM := 1;                                            45810000
               CIERR(ERRNUM := LDEVNOTREAL,FIRSTPARM);                  45815000
               RETURN;                                                  45820000
            END;                                                        45825000
            BEGIN    <<3>>  <<NOT SPOOLEE>>                             45830000
               PARMNUM := 1;                                            45835000
               RESETSPSQ;  <<RESET LDT SPOOLING BITS>>                  45840000
               CIERR(ERRNUM := DEVTYPENOTSPOOLEE,FIRSTPARM);            45845000
               RETURN;                                                  45850000
            END;                                                        45855000
            BEGIN    <<4>>  <<NOT JOB OR DATA ACCEPTING>>               45860000
               PARMNUM := 1;                                            45865000
               RESETSPSQ;                                               45870000
               CIERR(ERRNUM := DEVNOTJOBDATA,FIRSTPARM);                45875000
               RETURN;                                                  45880000
            END;                                                        45885000
            BEGIN     <<5>>  <<OWNED BY DIAGNOSTICS>>                   45890000
               PARMNUM := 1;                                            45895000
               CIERR(ERRNUM := DEVOWNEDDIAG,FIRSTPARM);                 45900000
               RETURN;                                                  45905000
            END;                                                        45910000
            BEGIN    <<6>>  <<NO STACK SEGMENT AVAIL>>                  45915000
               PARMNUM := 0;                                            45920000
               RESETSPSQ;                                               45925000
               CIERR(ERRNUM := UNABLETOGETSTACK);                       45930000
            END;                                                        45935000
            BEGIN    <<7>> <<UNABLE TO PROCREATE>>                      45940000
               PARMNUM := 0;                                            45945000
               RESETSPSQ;                                               45950000
               CIERR(ERRNUM := UNABLETOPROCREATE);                      45955000
               RETURN;                                                  45960000
            END;                                                        45965000
            BEGIN    <<8>>  <<SPOOLER PROCESS BUSY>>                    45970000
               PARMNUM := 0;                                            45975000
               RESETSPSQ;                                               45980000
               CIERR(ERRNUM := SPOOLERBUSY);                            45985000
               RETURN;                                                  45990000
            END;                                                        45995000
            BEGIN    <<9>>  <<DEVICE DOWNED, UNAVAILABLE>>     <<04833>>46000000
               PARMNUM := 0;                                   <<04833>>46005000
               RESETSPSQ;                                      <<04833>>46010000
               CIERR(ERRNUM:=DEVISDOWN);                       <<04833>>46015000
               RETURN;                                         <<04833>>46020000
            END;                                               <<04833>>46025000
        END;    <<CASE>>                                                46030000
      END                                                               46035000
      ELSE                                                              46040000
      BEGIN                                                             46045000
         PARMNUM:=1;                                                    46050000
         CIERR(ERRNUM:=USERNOACC2DEV,PARMSP);                           46055000
      END;                                                              46060000
   END;    << :STARTSPOOL {ldev} [;SHUTQ]                   >> <<07438>>46065000
END;   <<CXSTARTSPOOL>>                                        <<07438>>46070000
$PAGE "STOPSPOOL EXECUTOR"                                     <<04833>>46075000
$CONTROL SEGMENT=SPOOLCOMS2                                    <<04833>>46080000
                                                                        46085000
<< Note:  Procedure CXSTOPSPOOL was  moved  unchanged  from >> <<04833>>46090000
<< OPCOMMAND to SPOOLCOMS as part of this enhancement.  Its >> <<04833>>46095000
<< fix number(s) were not changed.                          >> <<04833>>46100000
                                                                        46105000
PROCEDURE CXSTOPSPOOL EXECUTORHEAD;                                     46110000
BEGIN                                                                   46115000
<<                                                                      46120000
   COMMENT                                                              46125000
      THE SYNTAX OF THIS COMMAND IS:                                    46130000
         STOPSPOOL {ldev     } [;OPENQ]                                 46135000
                    {deviceclass}                                       46140000
         WHERE ldev IS ANY REAL LOGICAL DEVICE                          46145000
   ;                                                                    46150000
>>                                                                      46155000
   DOUBLE DL := [8/",", 8/";", 8/%15, 8/0]D;                            46160000
   BYTE ARRAY DL'(*)=DL;                                                46165000
   DOUBLE ARRAY PARM(0:1)=Q;                                            46170000
   BYTE POINTER FIRSTPARM=PARM, SNDPARM=PARM+2, TRDPARM = PARM+4;       46175000
   BYTE LEN=PARM+1,LEN2 = PARM+3;                              <<04833>>46180000
   INTEGER PARM1 = PARM+1, PARM2=PARM+3;                       <<04833>>46185000
   EQUATE COMMA = 0, SEMICOLON = 1;                            <<04833>>46190000
   LOGICAL OPENQ := FALSE;                                     <<04833>>46195000
   LOGICAL LDEV;                                                        46200000
   INTEGER NUMPARMS;                                                    46205000
   LOGICAL POINTER DCT;                                        <<06744>>46210000
   <<CI/SPOOLER DIRECTIVE>>                                             46215000
   EQUATE NODIRECTIVE = %100000;                                        46220000
   INTEGER NEWDIRECTIVE := NODIRECTIVE;                                 46225000
   DEFINE PROCDIRECTIVE = NEWDIRECTIVE.(8:4)#,                          46230000
          FILEDIRECTIVE = NEWDIRECTIVE.(12:4)#;                         46235000
   INTEGER SAVE'LDT'SIR, SAVE'DCT'SIR;                         <<07438>>46240000
   INTEGER CLASS'ADDRESS, CLASS'LENGTH;                        <<07438>>46245000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY-1);                   <<06744>>46250000
   INTEGER LDT'INDEX := 0;                                     <<06744>>46255000
   INTEGER SPOOFLING;                                                   46260000
   EQUATE SHUT = 0,                                                     46265000
          OPEN = 1,                                            <<04833>>46270000
          UNCHANGED = 2;                                       <<04833>>46275000
      INTEGER ARRAY CLASSNAME(0:4);                            <<07438>>46280000
      BYTE ARRAY B'CLASSNAME(*) = CLASSNAME;                   <<04833>>46285000
      INTEGER ARRAY GETCLASSBUF(0:4);                          <<07438>>46290000
   LOGICAL ARRAY SPOOLINFO(0:3);                               <<04833>>46295000
                                                                        46300000
                                                               <<04833>>46305000
   SUBROUTINE DEF'MOVEFROMDSEG;                                         46310000
   SUBROUTINE DEF'MOVETODSEG;                                           46315000
                                                                        46320000
                                                                        46325000
   LOGIMAGE( M'STOPSPOOL, PARMSP );  << LOG OP COMMAND >>      <<04833>>46330000
   MYCOMMAND(PARMSP,DL',3,NUMPARMS,PARM);                      <<04833>>46335000
   ERRNUM := PARMNUM := 0;                                     <<04833>>46340000
   IF NUMPARMS = 0 THEN <<MUST HAVE AT LEAST 1 PARM>>          <<04833>>46345000
   BEGIN                                                       <<04833>>46350000
      CIERR(ERRNUM := -EXP1OFLDEVOROPENQ,PARMSP);              <<04833>>46355000
      RETURN;                                                  <<04833>>46360000
   END                                                         <<04833>>46365000
   ELSE                                                        <<04833>>46370000
   IF LEN=0 THEN                                               <<04833>>46375000
   BEGIN                                                       <<04833>>46380000
      PARMNUM := 1;                                            <<04833>>46385000
      CIERR(ERRNUM := EXPLDEVBAD,FIRSTPARM);                   <<04833>>46390000
      RETURN;                                                  <<04833>>46395000
   END                                                         <<04833>>46400000
   ELSE                                                        <<04833>>46405000
   IF NUMPARMS > 2 THEN                                        <<04833>>46410000
   BEGIN                                                       <<04833>>46415000
      PARMNUM := 2;                                            <<04833>>46420000
      CIERR(ERRNUM := STOPSP2PARM,TRDPARM);                    <<04833>>46425000
      RETURN;                                                  <<04833>>46430000
   END;                                                        <<04833>>46435000
   IF NUMPARMS = 2 THEN <<MAXIMUM NUMBER OF PARMS>>            <<04833>>46440000
   BEGIN                                                       <<04833>>46445000
      IF PARM1.DELIMITER <> SEMICOLON THEN                     <<04833>>46450000
      <<MUST HAVE SEMICOLON SEPARATION>>                       <<04833>>46455000
      BEGIN                                                    <<04833>>46460000
         PARMNUM := 2;                                         <<04833>>46465000
         CIERR(ERRNUM := EXPSEMICOLON,FIRSTPARM(LEN));    <<SP.36>>     46470000
      END                                                      <<04833>>46475000
      ELSE                                                     <<04833>>46480000
        <<IS OPENQ SPECIFIED?>>                                <<04833>>46485000
      BEGIN                                                    <<04833>>46490000
         IF LEN2 <> 5 OR SNDPARM <> "OPENQ" THEN             <<SP.36>>  46495000
         BEGIN                                                 <<04833>>46500000
            PARMNUM := 2;                                      <<04833>>46505000
            CIERR(ERRNUM := EXPOPENQ,SNDPARM);                 <<04833>>46510000
            RETURN;                                            <<04833>>46515000
         END                                                   <<04833>>46520000
         ELSE                                                  <<04833>>46525000
         OPENQ := TRUE;                                        <<04833>>46530000
      END;                                                     <<04833>>46535000
   END;                                                        <<04833>>46540000
   IF ERRNUM <> 0 THEN RETURN;                                 <<04833>>46545000
                                                               <<04833>>46550000
                                                               <<04833>>46555000
      LDEV := BINARY(FIRSTPARM,LEN);                           <<04833>>46560000
      IF < THEN                                                <<04833>>46565000
         BEGIN   << :STOPSPOOL {deviceclass}                >> <<07438>>46570000
         IF LEN > 8 THEN                                       <<04833>>46575000
         BEGIN  << CLASSNAME TOO LONG>>                        <<04833>>46580000
            PARMNUM := 1;                                      <<04833>>46585000
            CIERR(ERRNUM := EXPDEVCLASSLONG,FIRSTPARM);        <<04833>>46590000
            RETURN;                                            <<04833>>46595000
         END;                                                  <<04833>>46600000
         <<DETERMINE IF DEVCLASS IS ACCESSIBLE>>               <<04833>>46605000
         CLASSNAME := "  ";                                    <<07438>>46610000
         MOVE CLASSNAME(1) := CLASSNAME, (4);                  <<07438>>46615000
         MOVE B'CLASSNAME := FIRSTPARM, (LEN);                 <<07438>>46620000
         SAVE'DCT'SIR := GETSIR (DCT'SIR);                     <<07438>>46625000
         IF NOT GETCLASS (GETCLASSBUF, FALSE, , , CLASSNAME)   <<07438>>46630000
            THEN                                               <<07438>>46635000
            BEGIN                                              <<07438>>46640000
            RELSIR (DCT'SIR, SAVE'DCT'SIR);                    <<07438>>46645000
            PARMNUM := 1;                                      <<04833>>46650000
            CIERR(ERRNUM := BADCLASSNAME,FIRSTPARM);           <<04833>>46655000
            RETURN;                                            <<04833>>46660000
            END;                                               <<07438>>46665000
        IF VERIFY'MASTEROP'C(CLASSNAME) THEN                   <<04833>>46670000
           BEGIN                                               <<04833>>46675000
              RELSIR (DCT'SIR, SAVE'DCT'SIR);                  <<07438>>46680000
              RETURN;                                          <<04833>>46685000
           END;                                                <<04833>>46690000
         << IS REQUESTOR ASSOCIATOR OF THIS CLASS?>>           <<04833>>46695000
         IF CHECKASS'CLASS(,B'CLASSNAME) OR                    <<04833>>46700000
            CHECKALLOW(M'STARTSPOOL) THEN                      <<04833>>46705000
         <<USER HAS ACCESS>>                                   <<04833>>46710000
         ELSE                                                  <<04833>>46715000
         BEGIN                                                 <<04833>>46720000
            PARMNUM := 1;                                      <<04833>>46725000
            RELSIR (DCT'SIR, SAVE'DCT'SIR);                    <<07438>>46730000
            CIERR(ERRNUM := USERNOACC2CLASS,PARMSP);           <<04833>>46735000
            RETURN;                                            <<04833>>46740000
         END;                                                  <<04833>>46745000
                                                               <<04833>>46750000
         <<USER HAS ACCESS>>                                   <<04833>>46755000
         << TO CLASS      >>                                   <<04833>>46760000
         CLASS'LENGTH := GET'DEVICE'CLASS (GETCLASSBUF(1),     <<07438>>46765000
                                           CLASS'ADDRESS);     <<07438>>46770000
         PUSH (S);   << Build DCT entry on stack.           >> <<07438>>46775000
         @DCT := TOS + 1;                                      <<07438>>46780000
         TOS := CLASS'LENGTH;                                  <<07438>>46785000
         ASSEMBLE (ADDS 0);                                    <<07438>>46790000
         MOVEFROMDSEG (DCT, DCT'DST, CLASS'ADDRESS,            <<07438>>46795000
                       CLASS'LENGTH);                          <<07438>>46800000
         IF DCT'SPOOL'QUEUES = DCT'SHUT THEN                   <<07438>>46805000
         BEGIN  <<DEVICECLASS NOT SPOOLED>>                    <<04833>>46810000
            PARMNUM := 1;                                      <<04833>>46815000
            RELSIR (DCT'SIR, SAVE'DCT'SIR);                    <<07438>>46820000
            CIERR(ERRNUM := CLASSNOTSPOOLED,FIRSTPARM);        <<04833>>46825000
            RETURN;                                            <<04833>>46830000
         END;                                                  <<04833>>46835000
                                                               <<04833>>46840000
         IF NUMPARMS > 1 THEN                                  <<04833>>46845000
         BEGIN  <<CANNOT SPECIFY "OPENQ" WITH >>               <<04833>>46850000
                <<DEVICECLASS>>                                <<04833>>46855000
            PARMNUM := 2;                                      <<04833>>46860000
            RELSIR (DCT'SIR, SAVE'DCT'SIR);                    <<07438>>46865000
            CIERR(ERRNUM := CLASSXPARMS, SNDPARM);             <<04833>>46870000
            RETURN;                                            <<04833>>46875000
         END;                                                  <<04833>>46880000
         <<NOW WE CAN RESET THE SPOOLING BIT IN >>             <<04833>>46885000
         << THE DEVICE CLASS ENTRY>>                           <<04833>>46890000
         DCT'SPOOL'QUEUES := DCT'SHUT;                         <<07438>>46895000
         MOVETODSEG (DCT'DST, CLASS'ADDRESS, DCT,              <<07438>>46900000
                     CLASS'LENGTH);                            <<07438>>46905000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>46910000
         END     << :STOPSPOOL {deviceclass}                >> <<07438>>46915000
      ELSE                                                     <<04833>>46920000
   BEGIN   << :STOPSPOOL {ldev} [;OPENQ]                    >> <<07438>>46925000
      LDEV:=VERIFY'RLDEV(FIRSTPARM,LEN,ERRNUM,PARMNUM,1);               46930000
      IF < THEN RETURN;                                                 46935000
      IF VERIFY'MASTEROP(LDEV) THEN RETURN;<<MSTEROP MADE INADV. ENTRY>>46940000
      IF CHECKASS(LDEV) OR                                              46945000
         CHECKALLOW(M'STOPSPOOL) THEN <<USER HAS ACCESS>>               46950000
      BEGIN                                                             46955000
      PROCDIRECTIVE := QUITSPOOLING;                                    46960000
      FILEDIRECTIVE := RELINKFILE; <<CAUSES IMMEDIATE STOP>>   <<04833>>46965000
      SAVE'LDT'SIR := GETSIR (LDT'SIR);                        <<07438>>46970000
      MOVEFROMDSEG(  LDT, LDT'DST, LDEV*SIZE'OF'LDT'ENTRY,     <<06744>>46975000
                      SIZE'OF'LDT'ENTRY);                      <<06744>>46980000
      IF LDT'SPOOL'STATE = LDT'NOT'SPOOLED THEN                <<06744>>46985000
      BEGIN     <<NOT A SPOOLED DEVICE>>                                46990000
         PARMNUM := 1;                                                  46995000
         RELSIR (LDT'SIR, SAVE'LDT'SIR);                       <<07438>>47000000
         CIERR(ERRNUM := DEVICENOTSPOOLED,FIRSTPARM);                   47005000
         RETURN;                                                        47010000
      END                                                               47015000
      ELSE                                                              47020000
      BEGIN       <<A SPOOLER>>                                         47025000
         IF LDT'SPOOL'STATE = LDT'INPUT'SPOOLED THEN           <<06744>>47030000
         BEGIN <<INPUT SPOOLER>>                               <<04833>>47035000
            SPOOFLING := UNCHANGED;                            <<04833>>47040000
            IF NUMPARMS > 1 THEN                               <<04833>>47045000
            BEGIN <<OPENQ SPECIFIED FOR INPUT SPOOLEE>>        <<04833>>47050000
               PARMNUM := 2;                                   <<04833>>47055000
               RELSIR (LDT'SIR, SAVE'LDT'SIR);                 <<07438>>47060000
               CIERR(ERRNUM := OPENQINPUT,SNDPARM);            <<04833>>47065000
               RETURN;                                         <<04833>>47070000
            END;                                               <<04833>>47075000
         END;  <<INPUT SPOOLER>>                               <<04833>>47080000
                                                               <<04833>>47085000
         IF LDT'SPOOL'STATE = LDT'OUTPUT'SPOOLED THEN          <<06744>>47090000
         SPOOFLING := OPENQ; <<OPEN/SHUT THE SPOOLER QUEUE ON DEVICE>>  47095000
         IF NOT SENDSPOOLERMSG(LDEV,NEWDIRECTIVE,SPOOFLING,             47100000
                SPOOLINFO,                                     <<04833>>47105000
                ERRNUM,PARMNUM) THEN                                    47110000
         BEGIN                                                          47115000
            RELSIR (LDT'SIR, SAVE'LDT'SIR);                    <<07438>>47120000
            CIERR(ERRNUM,FIRSTPARM);                                    47125000
            RETURN;                                                     47130000
         END;                                                           47135000
         RELSIR (LDT'SIR, SAVE'LDT'SIR);                       <<07438>>47140000
      END;                                                              47145000
   END                                                                  47150000
   ELSE                                                                 47155000
      BEGIN                                                             47160000
         PARMNUM:=1;                                                    47165000
         CIERR(ERRNUM:=USERNOACC2DEV,PARMSP);                           47170000
      END;                                                              47175000
   END;    << :STOPSPOOL {ldev} [;OPENQ]                    >> <<07438>>47180000
END;   << CXSTOPSPOOL >>                                       <<04833>>47185000
$PAGE "SUSPENDSPOOL EXECUTOR"                                  <<04833>>47190000
$CONTROL SEGMENT=SPOOLCOMS2                                    <<04833>>47195000
                                                                        47200000
<< Note:  Procedure CXSUSPENDSPOOL was moved unchanged from >> <<04833>>47205000
<< OPCOMMAND to SPOOLCOMS as part of this enhancement.  Its >> <<04833>>47210000
<< fix number(s) were not changed.                          >> <<04833>>47215000
                                                                        47220000
PROCEDURE CXSUSPENDSPOOL EXECUTORHEAD;                                  47225000
BEGIN                                                                   47230000
   <<COMMENT                                                            47235000
      THE SYNTAX OF THIS COMMAND IS:                                    47240000
         SUSPENDSPOOL LDEV [;FINISH]                                    47245000
         WHERE LDEV IS ANY REAL LOGICAL DEVICE                          47250000
         FINISH INDICATES SUSPEND AFTER CURRENTLY ACTIVE                47255000
         SPOOLFILE IS FINISHED PRINTING                                 47260000
                                                                        47265000
   ; >>                                                                 47270000
   DOUBLE DL := [8/",", 8/";", 8/%15, 8/0]D;                            47275000
   BYTE ARRAY DL'(*)=DL;                                                47280000
   DOUBLE ARRAY PARM(0:2)=Q;                                            47285000
   BYTE POINTER FIRSTPARM=PARM, SNDPARM=PARM+2, TRDPARM = PARM+4;       47290000
   BYTE FIRSTLEN=PARM+1,SNDLEN=PARM+3;                                  47295000
   LOGICAL LDEV;                                                        47300000
   INTEGER PARM1=PARM+1,PARM2=PARM+3;                                   47305000
   EQUATE COMMA = 0,                                                    47310000
          SEMICOLON = 1;                                                47315000
   LOGICAL FINISH := FALSE;                                             47320000
   INTEGER NUMPARMS;                                                    47325000
   INTEGER LDT'INDEX := 0;                                     <<06744>>47330000
   EQUATE <<DIRECTION>>                                                 47335000
          IN=0,                                                         47340000
          OUT=3, <<SPOOFLING ON + OUTPUT SPOOLING>>                     47345000
          EITHER = -1;                                                  47350000
   INTEGER DIRECTION := EITHER;                                         47355000
   <<CI/SPOOLER DIRECTIVE>>                                             47360000
   EQUATE NODIRECTIVE = %100000;                                        47365000
   INTEGER NEWDIRECTIVE := NODIRECTIVE;                                 47370000
   DEFINE PROCDIRECTIVE = NEWDIRECTIVE.(8:4)#,                          47375000
          FILEDIRECTIVE = NEWDIRECTIVE.(12:4)#;                         47380000
   INTEGER SAVESIR;                                            <<07438>>47385000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY-1);                   <<06744>>47390000
   INTEGER SPOOFLING;                                                   47395000
   EQUATE SHUT = 0,                                                     47400000
          OPEN = 1,                                            <<04833>>47405000
          UNCHANGED = 2;                                       <<04833>>47410000
   LOGICAL ARRAY SPOOLINFO(0:3);                               <<04833>>47415000
                                                                        47420000
   SUBROUTINE DEF'MOVEFROMDSEG;                                         47425000
   SUBROUTINE DEF'MOVETODSEG;                                           47430000
                                                                        47435000
                                                                        47440000
   LOGIMAGE( M'SUSPENDSPOOL, PARMSP );  << LOG OP COMMAND >>   <<04833>>47445000
   MYCOMMAND(PARMSP,DL',3,NUMPARMS,PARM);                               47450000
   ERRNUM := PARMNUM := 0;                                              47455000
   IF NUMPARMS = 0 THEN <<MUST HAVE AT LEAST 1 PARM>>                   47460000
   BEGIN                                                                47465000
      CIERR(ERRNUM := -EXP1OFLDEVORFIN,PARMSP);                         47470000
      RETURN;                                                           47475000
   END                                                                  47480000
   ELSE                                                                 47485000
   IF FIRSTLEN=0 THEN                                          <<04833>>47490000
   BEGIN                                                       <<04833>>47495000
      PARMNUM := 1;                                            <<04833>>47500000
      CIERR(ERRNUM := EXPLDEVBAD,FIRSTPARM);                   <<04833>>47505000
      RETURN;                                                  <<04833>>47510000
   END                                                         <<04833>>47515000
   ELSE                                                        <<04833>>47520000
   IF NUMPARMS > 2 THEN                                                 47525000
   BEGIN                                                                47530000
      PARMNUM := 2;                                                     47535000
      CIERR(ERRNUM := SUSPENDSP2PARM,TRDPARM);                          47540000
      RETURN;                                                           47545000
   END;                                                                 47550000
   IF NUMPARMS = 2 THEN <<MAXIMUM NUMBER OF PARMS>>                     47555000
   BEGIN                                                                47560000
      IF PARM1.DELIMITER <> SEMICOLON THEN                              47565000
      <<MUST HAVE SEMICOLON SEPARATION>>                                47570000
      BEGIN                                                             47575000
         PARMNUM := 2;                                                  47580000
         CIERR(ERRNUM := EXPSEMICOLON,FIRSTPARM(FIRSTLEN));             47585000
      END                                                               47590000
      ELSE                                                              47595000
      IF SNDLEN <> 0 THEN <<FINISH SPECIFIED?>>                         47600000
      BEGIN                                                             47605000
         IF SNDLEN <> 6 OR SNDPARM <> "FINISH" THEN                     47610000
         BEGIN                                                          47615000
            PARMNUM := 2;                                               47620000
            CIERR(ERRNUM := EXPFINISH,SNDPARM);                         47625000
            RETURN;                                                     47630000
         END                                                            47635000
         ELSE                                                           47640000
         FINISH := TRUE;                                                47645000
      END;                                                              47650000
   END;                                                                 47655000
   IF ERRNUM <> 0 THEN RETURN;                                          47660000
      LDEV:=VERIFY'RLDEV(FIRSTPARM,FIRSTLEN,ERRNUM,PARMNUM,1);          47665000
      IF < THEN RETURN;                                                 47670000
      IF VERIFY'MASTEROP(LDEV) THEN RETURN;<<MSTEROP MADE INADV. ENTRY>>47675000
      IF CHECKASS(LDEV) OR                                              47680000
         CHECKALLOW(M'SUSPENDSPOOL) THEN <<USER HAS ACCESS>>            47685000
      BEGIN                                                             47690000
      PROCDIRECTIVE := WAITSPOOLING;                                    47695000
      DIRECTION := OUT;                                                 47700000
      SAVESIR := GETSIR( LDT'SIR );                            <<06744>>47705000
      MOVEFROMDSEG( LDT, LDT'DST, LDEV*SIZE'OF'LDT'ENTRY,      <<06744>>47710000
                     SIZE'OF'LDT'ENTRY);                       <<06744>>47715000
      IF LDT'SPOOL'STATE = LDT'NOT'SPOOLED THEN                <<06744>>47720000
      BEGIN     <<NOT A SPOOLED DEVICE>>                                47725000
         PARMNUM := 1;                                                  47730000
         RELSIR(LDT'SIR,SAVESIR);                              <<06744>>47735000
         CIERR(ERRNUM := DEVICENOTSPOOLED,FIRSTPARM);                   47740000
         RETURN;                                                        47745000
      END                                                               47750000
      ELSE                                                              47755000
      IF LDT'SPOOL'STATE = LDT'INPUT'SPOOLED THEN<<INPUT >>    <<06744>>47760000
      BEGIN                                                             47765000
         PARMNUM := 1;                                                  47770000
         RELSIR(LDT'SIR,SAVESIR);                              <<06744>>47775000
         CIERR(ERRNUM := DEVICENOTOUTSPOOL,FIRSTPARM);                  47780000
         RETURN;                                                        47785000
      END                                                               47790000
      ELSE                                                              47795000
      BEGIN       << An output spooler >>                      <<07438>>47800000
         SPOOFLING := UNCHANGED; <<LEAVE  SPOOL QUEUE >>       <<04833>>47805000
         IF NOT FINISH THEN FILEDIRECTIVE := RELINKFILE;                47810000
         IF NOT SENDSPOOLERMSG(LDEV,NEWDIRECTIVE,SPOOFLING,             47815000
                SPOOLINFO,                                     <<04833>>47820000
                ERRNUM,PARMNUM) THEN                                    47825000
         BEGIN                                                          47830000
            RELSIR(LDT'SIR,SAVESIR);                           <<06744>>47835000
            CIERR(ERRNUM,FIRSTPARM);                                    47840000
            RETURN;                                                     47845000
         END;                                                           47850000
         RELSIR(LDT'SIR,SAVESIR);                              <<06744>>47855000
      END;                                                              47860000
   END                                                                  47865000
   ELSE                                                                 47870000
      BEGIN                                                             47875000
         PARMNUM:=1;                                                    47880000
         CIERR(ERRNUM:=USERNOACC2DEV,PARMSP);                           47885000
      END;                                                              47890000
END;   << CXSUSPENDSPOOL >>                                    <<04833>>47895000
$PAGE "RESUMESPOOL EXECUTOR"                                   <<04833>>47900000
$CONTROL SEGMENT=SPOOLCOMS2                                    <<04833>>47905000
                                                                        47910000
<< Note:  Procedure CXRESUMESPOOL was moved unchanged  from >> <<04833>>47915000
<< OPCOMMAND to SPOOLCOMS as part of this enhancement.  Its >> <<04833>>47920000
<< fix number(s) were not changed.                          >> <<04833>>47925000
                                                                        47930000
PROCEDURE CXRESUMESPOOL EXECUTORHEAD;                                   47935000
BEGIN                                                                   47940000
<<                                                             ((MPEIV))47945000
   COMMENT                                                              47950000
      THE SYNTAX OF THIS COMMAND IS:                                    47955000
         RESUMESPOOL LDEV [; {BACK}              {nnn FILES} ] ((MPEIV))47960000
                          [; {FORWARD}           {nnn[PAGES]}] ((MPEIV))47965000
                          [; {BEGINNING                     }] ((MPEIV))47970000
                                                               ((MPEIV))47975000
         WHERE LDEV IS ANY REAL LOGICAL DEVICE                          47980000
         AND nnn <= 256.                                       ((MPEIV))47985000
   ;                                                                    47990000
>>                                                             <<04833>>47995000
   DOUBLE DL := [8/" ", 8/";", 8/",", 8/%15]D;                 <<04833>>48000000
   INTEGER DLEND := 0;   <<END OF DELIMITERS>>                 <<04833>>48005000
   BYTE ARRAY DL'(*)=DL;                                                48010000
   DOUBLE ARRAY PARM(0:6) = Q;                                 <<04833>>48015000
   BYTE POINTER FIRSTPARM=PARM, SNDPARM=PARM+2;                         48020000
   BYTE POINTER THIRDPARM=PARM+4,FOURTHPARM=PARM+6;            <<04833>>48025000
   BYTE LEN=PARM+1;                                                     48030000
   BYTE LEN2=PARM+3, LEN3=PARM+5,LEN4=PARM+7,LEN5=PARM+9;      <<04833>>48035000
   EQUATE BLANK = 0, SEMICOLON = 1,COMMA = 2, CR = 3;          <<04833>>48040000
   INTEGER PARM1 = PARM+1, PARM2 = PARM+3,                     <<04833>>48045000
           PARM3 = PARM+5, PARM4 = PARM + 7, PARM5 = PARM + 9; <<07438>>48050000
   LOGICAL LDEV;                                                        48055000
   INTEGER NUMPARMS;                                                    48060000
   INTEGER LDT'INDEX := 0;                                     <<06744>>48065000
   EQUATE <<DIRECTION>>                                                 48070000
          IN=0,                                                         48075000
          OUT=3, <<SPOOFLING ON + OUTPUT SPOOLING>>                     48080000
          EITHER = -1;                                                  48085000
   INTEGER DIRECTION := EITHER;                                         48090000
   <<CI/SPOOLER DIRECTIVE>>                                             48095000
   EQUATE NODIRECTIVE = %100000;                                        48100000
   INTEGER NEWDIRECTIVE := NODIRECTIVE;                                 48105000
   DEFINE PROCDIRECTIVE = NEWDIRECTIVE.(8:4)#;                 <<07438>>48110000
   INTEGER SAVESIR;                                            <<07438>>48115000
   INTEGER SAVEODD;                                            <<04833>>48120000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY-1);                   <<06744>>48125000
   LOGICAL DFID, ACTIVE;                                       <<04833>>48130000
   INTEGER SPOOFLING;                                                   48135000
   EQUATE SHUT = 0,                                                     48140000
          OPEN = 1,                                            <<04833>>48145000
          UNCHANGED = 2;                                       <<04833>>48150000
   LOGICAL BACK;                                               <<04833>>48155000
   INTEGER PAGES := 0;                                         <<04833>>48160000
   INTEGER FILES := 0;                                         <<04833>>48165000
   BYTE ARRAY BNUMBER(0:3);                                    <<04833>>48170000
   INTEGER BNUMLEN,NUMBER;                                     <<04833>>48175000
   LOGICAL ARRAY SPOOLINFO(0:3);                               <<04833>>48180000
                                                                        48185000
   SUBROUTINE DEF'MOVEFROMDSEG;                                         48190000
   SUBROUTINE DEF'MOVETODSEG;                                           48195000
                                                                        48200000
                                                                        48205000
   LOGIMAGE( M'RESUMESPOOL, PARMSP );  << LOG OP COMMAND >>    <<04833>>48210000
   MYCOMMAND(PARMSP,DL',5,NUMPARMS,PARM);                      <<04833>>48215000
   IF NUMPARMS < 1 THEN                                        <<04833>>48220000
   BEGIN                                                       <<04833>>48225000
      PARMNUM := 1;                                            <<04833>>48230000
      CIERR( ERRNUM := RESUMESPREQ1P,PARMSP);                  <<04833>>48235000
      RETURN;                                                  <<04833>>48240000
   END;                                                        <<04833>>48245000
   IF NUMPARMS = 1 OR LEN2 = 0  THEN                           <<04833>>48250000
   BEGIN     <<RESTART LDEV FROM BEGINNING >>                  <<04833>>48255000
      BACK := TRUE;                                            <<04833>>48260000
      PAGES := 0 ;  <<BEGINNING>>                              <<04833>>48265000
   END                                                         <<04833>>48270000
   ELSE                                                        <<04833>>48275000
   BEGIN     <<MORE THAN ONE PARM>>                            <<04833>>48280000
      IF PARM1.DELIMITER <> SEMICOLON THEN                     <<04833>>48285000
      BEGIN  << EXPECTED SEMICOLON AFTER LDEV>>                <<04833>>48290000
         PARMNUM := 2;                                         <<04833>>48295000
         CIERR(ERRNUM := EXPSEMICOLON,FIRSTPARM(LEN));         <<04833>>48300000
         RETURN;                                               <<04833>>48305000
      END;                                                     <<04833>>48310000
      IF SNDPARM = "BACK" AND LEN2 = 4 THEN                    <<04833>>48315000
         BACK := TRUE                                          <<04833>>48320000
      ELSE                                                     <<04833>>48325000
      IF SNDPARM = "FORWARD"  AND LEN2 = 7 THEN                <<04833>>48330000
         BACK := FALSE                                         <<04833>>48335000
      ELSE                                                     <<04833>>48340000
      IF SNDPARM = "BEGINNING" AND LEN2 = 9 THEN               <<04833>>48345000
      BEGIN           <<BEGINNING>>                            <<04833>>48350000
         BACK := TRUE;                                         <<04833>>48355000
         PAGES := -1; <<BACK TO BEGINNING>>                    <<04833>>48360000
         IF NUMPARMS > 2 AND LEN3 <> 0 THEN                    <<04833>>48365000
         BEGIN                                                 <<04833>>48370000
            PARMNUM := 3;                                      <<04833>>48375000
            CIERR(ERRNUM := RESUMESPBEGINX, THIRDPARM);        <<04833>>48380000
            RETURN;                                            <<04833>>48385000
         END                                                   <<04833>>48390000
         ELSE                                                  <<04833>>48395000
         GO TO LDEVCHECK;                                      <<04833>>48400000
      END                                                      <<04833>>48405000
      ELSE                                                     <<04833>>48410000
      BEGIN          <<ILLEGAL PARM>>                          <<04833>>48415000
         PARMNUM := 2;                                         <<04833>>48420000
         CIERR(ERRNUM := EXPBACKORFORWARD,SNDPARM);            <<04833>>48425000
         RETURN;                                               <<04833>>48430000
      END;                                                     <<04833>>48435000
                                                               <<04833>>48440000
      IF PARM2.DELIMITER <> BLANK THEN                         <<04833>>48445000
      BEGIN  <<EXPECTED BLANK AFTER FORWARD/BACK>>             <<04833>>48450000
         PARMNUM := 3;                                         <<04833>>48455000
         CIERR(ERRNUM := EXPBLANK,SNDPARM(LEN2));              <<04833>>48460000
         RETURN;                                               <<04833>>48465000
      END;                                                     <<04833>>48470000
                                                               <<04833>>48475000
             <<THIRDPARM IS NUMERIC NUMBER OF PAGES/FILES>>    <<04833>>48480000
      MOVE BNUMBER := THIRDPARM WHILE N,1;                     <<04833>>48485000
      BNUMLEN := TOS - @BNUMBER;                               <<04833>>48490000
      IF BNUMLEN<>INTEGER(LEN3) THEN                           <<04833>>48495000
      BEGIN                                                    <<04833>>48500000
         PARMNUM:=3;                                           <<04833>>48505000
         CIERR(ERRNUM:=EXPBLANK, THIRDPARM(BNUMLEN));          <<04833>>48510000
         RETURN;                                               <<04833>>48515000
      END;                                                     <<04833>>48520000
      NUMBER := BINARY(BNUMBER,BNUMLEN);                       <<04833>>48525000
      IF < OR NUMBER = 0 OR NOT (1<=NUMBER<=256) THEN          <<04833>>48530000
      BEGIN                                                    <<04833>>48535000
         PARMNUM := 3;                                         <<04833>>48540000
         CIERR(ERRNUM := EXPNUM1TO256,THIRDPARM);              <<04833>>48545000
         RETURN;                                               <<04833>>48550000
      END;                                                     <<04833>>48555000
      IF PARM3.DELIMITER <> BLANK THEN                         <<04833>>48560000
      BEGIN                                                    <<04833>>48565000
         IF PARM3.DELIMITER <> CR THEN                         <<04833>>48570000
         BEGIN                                                 <<04833>>48575000
            PARMNUM := 3;                                      <<04833>>48580000
            CIERR(ERRNUM := EXPBLANK, THIRDPARM(LEN3));        <<04833>>48585000
            RETURN;                                            <<04833>>48590000
         END                                                   <<04833>>48595000
         ELSE                                                  <<04833>>48600000
         BEGIN      << REACHED CARRIAGE RETURN>>               <<04833>>48605000
            PAGES := NUMBER;                                   <<04833>>48610000
            GO TO LDEVCHECK;                                   <<04833>>48615000
         END;                                                  <<04833>>48620000
      END                                                      <<04833>>48625000
      ELSE IF LEN4 <> 5 AND LEN4 <> 0 THEN                     <<04833>>48630000
      BEGIN <<EXPECTED PAGES OR FILES>>                        <<04833>>48635000
         PARMNUM := 4;                                         <<04833>>48640000
         CIERR(ERRNUM := EXPPAGESORFILES, FOURTHPARM);         <<04833>>48645000
         RETURN;                                               <<04833>>48650000
      END                                                      <<04833>>48655000
      ELSE                                                     <<04833>>48660000
      IF  FOURTHPARM = "PAGES"  THEN                           <<04833>>48665000
          PAGES := NUMBER                                      <<04833>>48670000
      ELSE IF FOURTHPARM = "FILES" THEN FILES := NUMBER        <<04833>>48675000
      ELSE                                                     <<04833>>48680000
         BEGIN   << Not FILES/PAGES, better be end of input >> <<07438>>48685000
         IF LEN4 = 0 AND PARM4.DELIMITER = CR THEN             <<07438>>48690000
            BEGIN   << Legal end, courtesy of MYCOMMAND.    >> <<07438>>48695000
            PAGES := NUMBER;   << Take default.             >> <<07438>>48700000
            GO TO LDEVCHECK;                                   <<07438>>48705000
            END;    << Legal end, courtesy of MYCOMMAND.    >> <<07438>>48710000
         PARMNUM := 4;   << Not end of input, illegal.      >> <<07438>>48715000
         CIERR (ERRNUM := EXPPAGESORFILES, FOURTHPARM);        <<07438>>48720000
         RETURN;                                               <<07438>>48725000
         END;    << Not FILES/PAGES, better be end of input >> <<07438>>48730000
      IF NUMPARMS > 4 THEN                                     <<04833>>48735000
          IF PARM4.DELIMITER <> BLANK OR                       <<04833>>48740000
             (LEN5 <> 0 OR PARM5.DELIMITER <> CR) THEN         <<07438>>48745000
       <<WE HAVE REACHED THE END OF COMMAND STRING>>           <<04833>>48750000
         BEGIN     <<TOO MANY PARMS>>                          <<04833>>48755000
            PARMNUM := 5;                                      <<04833>>48760000
            CIERR(ERRNUM := EXP4PARMS,FOURTHPARM(LEN4));       <<04833>>48765000
            RETURN;                                            <<04833>>48770000
         END;                                                  <<04833>>48775000
   END;  <<MORE THAN ONE PARM>>                                <<04833>>48780000
LDEVCHECK:                                                     <<04833>>48785000
   BEGIN                                                                48790000
      LDEV:=VERIFY'RLDEV(FIRSTPARM,LEN,ERRNUM,PARMNUM,1);               48795000
      IF < THEN RETURN;                                                 48800000
      IF VERIFY'MASTEROP(LDEV) THEN RETURN;<<MSTEROP MADE INADV. ENTRY>>48805000
      IF CHECKASS(LDEV) OR                                              48810000
         CHECKALLOW(M'RESUMESPOOL) THEN <<USER HAS ACCESS>>             48815000
      BEGIN                                                             48820000
      PROCDIRECTIVE := RESUMESPOOLING;                                  48825000
      DIRECTION := OUT;                                                 48830000
      SAVESIR := GETSIR( LDT'SIR );                            <<06744>>48835000
      MOVEFROMDSEG(  LDT, LDT'DST, LDEV*SIZE'OF'LDT'ENTRY,     <<06744>>48840000
                     SIZE'OF'LDT'ENTRY);                       <<06744>>48845000
      IF LDT'SPOOL'STATE = LDT'NOT'SPOOLED THEN                <<06744>>48850000
      BEGIN     <<NOT A SPOOLED DEVICE>>                                48855000
         PARMNUM := 1;                                                  48860000
         RELSIR(LDT'SIR,SAVESIR);                              <<06744>>48865000
         CIERR(ERRNUM := DEVICENOTSPOOLED,FIRSTPARM);                   48870000
         RETURN;                                                        48875000
      END                                                               48880000
      ELSE                                                              48885000
      IF LDT'SPOOL'STATE = LDT'INPUT'SPOOLED THEN<<INPUT>>     <<06744>>48890000
      BEGIN                                                             48895000
         PARMNUM := 1;                                                  48900000
         RELSIR(LDT'SIR,SAVESIR);                              <<06744>>48905000
         CIERR(ERRNUM := DEVICENOTOUTSPOOL,FIRSTPARM);                  48910000
         RETURN;                                                        48915000
      END                                                               48920000
      ELSE                                                              48925000
      BEGIN       << An output spooler >>                      <<07438>>48930000
         SAVEODD := GETSIR(ODD'SIR);                           <<06744>>48935000
         ACTIVE := SFINDACTIVE(LDEV,DFID);                     <<04833>>48940000
         RELSIR(ODD'SIR,SAVEODD);                              <<06744>>48945000
         IF ACTIVE THEN                                        <<04833>>48950000
         BEGIN  <<ATTEMPTED RESUMESPOOL ON ACTIVE LDEV>>       <<04833>>48955000
            RELSIR(LDT'SIR,SAVESIR);                           <<06744>>48960000
            CIERR(ERRNUM := DEVICEACTIVE, FIRSTPARM);          <<04833>>48965000
            RETURN;                                            <<04833>>48970000
         END                                                   <<04833>>48975000
         ELSE                                                  <<04833>>48980000
         BEGIN <<OK: WE CAN NOW EXECUTE COMMAND>>              <<04833>>48985000
         SPOOFLING := UNCHANGED; <<LEAVE  SPOOL QUEUE >>       <<04833>>48990000
         SPOOLINFO := BACK;                                    <<04833>>48995000
         SPOOLINFO(1) := PAGES;                                <<04833>>49000000
         SPOOLINFO(2) := FILES;                                <<04833>>49005000
         IF NOT SENDSPOOLERMSG(LDEV,NEWDIRECTIVE,SPOOFLING,             49010000
                SPOOLINFO,                                     <<04833>>49015000
                ERRNUM,PARMNUM) THEN                                    49020000
         BEGIN                                                          49025000
            RELSIR(LDT'SIR,SAVESIR);                           <<06744>>49030000
            CIERR(ERRNUM,FIRSTPARM);                                    49035000
            RETURN;                                                     49040000
         END;                                                           49045000
         RELSIR(LDT'SIR,SAVESIR);                              <<06744>>49050000
         END; <<END OF EXECUTION>>                             <<04833>>49055000
      END;                                                              49060000
   END                                                                  49065000
   ELSE                                                                 49070000
      BEGIN                                                             49075000
         PARMNUM:=1;                                                    49080000
         CIERR(ERRNUM:=USERNOACC2DEV,PARMSP);                           49085000
      END;                                                              49090000
   END;                                                                 49095000
END;   << CXRESUMESPOOL >>                                     <<04833>>49100000
$PAGE "OPENQ EXECUTOR"                                         <<06914>>49105000
PROCEDURE CXOPENQ EXECUTORHEAD;                                <<06914>>49110000
BEGIN                                                          <<06914>>49115000
<<----------------------------------------------------------->><<06914>>49120000
<<                                                           >><<06914>>49125000
<<    THE SYNTAX OF THIS COMMAND IS:                         >><<06914>>49130000
<<       OPENQ {ldev     }                                   >><<06914>>49135000
<<             {deviceclass}                                 >><<06914>>49140000
<<       WHERE ldev MUST BE A SPOOLABLE DEVICE               >><<06914>>49145000
<<             deviceclass MUST CONTAIN AT LEAST ONE         >><<06914>>49150000
<<                         SPOOLABLE DEVICE                  >><<06914>>49155000
<<                                                           >><<06914>>49160000
<<----------------------------------------------------------->><<06914>>49165000
                                                               <<06914>>49170000
   DOUBLE DL := [8/",", 8/";", 8/%15, 8/0]D;                   <<06914>>49175000
   BYTE ARRAY DL'(*)=DL;                                       <<06914>>49180000
   DOUBLE ARRAY PARM(0:1)=Q;                                   <<06914>>49185000
   BYTE POINTER FIRSTPARM=PARM, SNDPARM=PARM+2;                <<06914>>49190000
   BYTE LEN=PARM+1;                                            <<06914>>49195000
   LOGICAL LDEV;                                               <<06914>>49200000
   INTEGER NUMPARMS;                                           <<06914>>49205000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY - 1);                 <<06914>>49210000
   INTEGER LDT'INDEX:=0;                                       <<06914>>49215000
   LOGICAL POINTER DCT;                                        <<06914>>49220000
   EQUATE <<DIRECTION>>                                        <<06914>>49225000
          IN=0,                                                <<06914>>49230000
          OUT=1, << OUTPUT SPOOLING>>                          <<06914>>49235000
          EITHER = -1;                                         <<06914>>49240000
   INTEGER DIRECTION := EITHER;                                <<06914>>49245000
   INTEGER SAVE'LDT'SIR,SAVE'DCT'SIR;                          <<06914>>49250000
   INTEGER ARRAY DEVINFO(0:SIZE'OF'GETDEVINFO) = Q;            <<06914>>49255000
   INTEGER INFO;                                               <<06914>>49260000
   INTEGER ARRAY CLASSNAME(0:4);                               <<07438>>49265000
   BYTE ARRAY B'CLASSNAME(*) = CLASSNAME;                      <<06914>>49270000
   INTEGER ARRAY GETCLASSBUF(0:4);                             <<07438>>49275000
   INTEGER CLASS'ADDRESS, CLASS'LENGTH, NUMDEVS;               <<07438>>49280000
                                                               <<06914>>49285000
   SUBROUTINE DEF'MOVEFROMDSEG;                                <<06914>>49290000
   SUBROUTINE DEF'MOVETODSEG;                                  <<06914>>49295000
                                                               <<06914>>49300000
<< >>                                                          <<06914>>49305000
   SUBROUTINE TELL'UCOP;                                       <<06914>>49310000
   <<awake ucop pin by setting jobsync flag>>                  <<06914>>49315000
   <<any jobs in queue waiting for this class or device >>     <<06914>>49320000
   <<can then execute>>                                        <<06914>>49325000
   BEGIN                                                       <<06914>>49330000
      DISABLE;                                                 <<06914>>49335000
      SYSDEVAVAIL := TRUE;                                     <<07438>>49340000
      ENABLE;                                                  <<06914>>49345000
      AWAKE (SYSUCOPPCB, JUNKWAIT, 0);                         <<07438>>49350000
   END; <<TELL'UCOP>>                                          <<06914>>49355000
                                                               <<06914>>49360000
<< begin procedure CXOPENQ >>                                  <<06914>>49365000
                                                               <<06914>>49370000
   LOGIMAGE( M'OPENQ, PARMSP );  << log op command >>          <<06914>>49375000
   MYCOMMAND(PARMSP,DL',2,NUMPARMS,PARM);                      <<06914>>49380000
   ERRNUM := PARMNUM := 0;                                     <<06914>>49385000
   IF NUMPARMS = 0 THEN << requires 1 parm >>                  <<06914>>49390000
   BEGIN                                                       <<06914>>49395000
      CIERR(ERRNUM := EXPLDEVORCLASS, PARMSP);                 <<06914>>49400000
      RETURN;                                                  <<06914>>49405000
   END                                                         <<06914>>49410000
   ELSE                                                        <<06914>>49415000
   IF LEN=0 THEN       << bad parameter >>                     <<06914>>49420000
   BEGIN                                                       <<06914>>49425000
      PARMNUM := 1;                                            <<06914>>49430000
      CIERR(ERRNUM := EXPLDEVBAD,FIRSTPARM);                   <<06914>>49435000
      RETURN;                                                  <<06914>>49440000
   END                                                         <<06914>>49445000
   ELSE                                                        <<06914>>49450000
   IF NUMPARMS > 1 THEN    << too many parms >>                <<06914>>49455000
   BEGIN                                                       <<06914>>49460000
      PARMNUM := 1;                                            <<06914>>49465000
      CIERR(ERRNUM := OPENQ1PARM, SNDPARM);                    <<06914>>49470000
      RETURN;                                                  <<06914>>49475000
   END;                                                        <<06914>>49480000
                                                               <<06914>>49485000
   << parm seems OK. now see if device class, then try ldev >> <<06914>>49490000
   LDEV := BINARY(FIRSTPARM,LEN);                              <<06914>>49495000
   IF < THEN                                                   <<06914>>49500000
   BEGIN  << assume device class >>                            <<06914>>49505000
      IF LEN > 8 THEN                                          <<06914>>49510000
      BEGIN  << classname too long>>                           <<06914>>49515000
         PARMNUM := 1;                                         <<06914>>49520000
         CIERR(ERRNUM := EXPDEVCLASSLONG,FIRSTPARM);           <<06914>>49525000
         RETURN;                                               <<06914>>49530000
      END;                                                     <<06914>>49535000
      <<determine if devclass is accessible>>                  <<06914>>49540000
      CLASSNAME := "  ";                                       <<07438>>49545000
      MOVE CLASSNAME(1) := CLASSNAME, (4);                     <<07438>>49550000
      MOVE B'CLASSNAME := FIRSTPARM, (LEN);                    <<07438>>49555000
      SAVE'DCT'SIR := GETSIR (DCT'SIR);                        <<07438>>49560000
      IF NOT GETCLASS (GETCLASSBUF, FALSE, , , CLASSNAME) THEN <<07438>>49565000
      BEGIN                                                    <<06914>>49570000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>49575000
         PARMNUM := 1;                                         <<06914>>49580000
         CIERR(ERRNUM := BADCLASSNAME,FIRSTPARM);              <<06914>>49585000
         RETURN;                                               <<06914>>49590000
      END;                                                     <<06914>>49595000
                                                               <<06914>>49600000
      IF VERIFY'MASTOP'C(CLASSNAME) THEN                       <<06914>>49605000
      BEGIN                                                    <<06914>>49610000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>49615000
         RETURN;                                               <<06914>>49620000
      END;                                                     <<06914>>49625000
                                                               <<06914>>49630000
      << is requestor associator of this class, or >>          <<06914>>49635000
      << allowed this command?                     >>          <<06914>>49640000
      IF CHECKASS'CLASS(,B'CLASSNAME) OR                       <<06914>>49645000
         CHECKALLOW(M'OPENQ) THEN                              <<06914>>49650000
      <<user has access>>                                      <<06914>>49655000
      ELSE                                                     <<06914>>49660000
      BEGIN                                                    <<06914>>49665000
         PARMNUM := 1;                                         <<06914>>49670000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>49675000
         CIERR(ERRNUM := USERNOACC2CLASS,PARMSP);              <<06914>>49680000
         RETURN;                                               <<06914>>49685000
      END;                                                     <<06914>>49690000
                                                               <<06914>>49695000
      <<OK, user has access to class >>                        <<06914>>49700000
      << check if output spoolable class >>                    <<06914>>49705000
      CLASS'LENGTH := GET'DEVICE'CLASS (GETCLASSBUF(1),        <<07438>>49710000
                                        CLASS'ADDRESS);        <<07438>>49715000
      PUSH (S);   << Build DCT entry on stack.              >> <<07438>>49720000
      @DCT := TOS + 1;                                         <<07438>>49725000
      TOS := CLASS'LENGTH;                                     <<07438>>49730000
      ASSEMBLE (ADDS 0);                                       <<07438>>49735000
      MOVEFROMDSEG (DCT, DCT'DST, CLASS'ADDRESS,               <<07438>>49740000
                    CLASS'LENGTH);                             <<07438>>49745000
                                                               <<07438>>49750000
<< Valid spoolee if any device in class is valid.           >> <<07438>>49755000
                                                               <<07438>>49760000
      NUMDEVS := DCT'NUM'DEVICES - 1;                          <<07438>>49765000
      DIRECTION := OUT;                                        <<07438>>49770000
      DO BEGIN   << Don't need LDT'SIR to fetch DEVTYPE.    >> <<07438>>49775000
         MOVEFROMDSEG (LDT, LDT'DST, DCT(DCT'FIRST'LDEV        <<07438>>49780000
            + NUMDEVS) * SIZE'OF'LDT'ENTRY,                    <<07438>>49785000
            SIZE'OF'LDT'ENTRY);                                <<07438>>49790000
         END                                                   <<07438>>49795000
        UNTIL VALIDSPOOLEE (LDT'DEVICE'TYPE, DIRECTION)        <<07438>>49800000
              OR (NUMDEVS := NUMDEVS - 1) < 0;                 <<07438>>49805000
      IF NUMDEVS < 0 THEN                                      <<07438>>49810000
      BEGIN                                                    <<06914>>49815000
         PARMNUM := 1;                                         <<06914>>49820000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>49825000
         CIERR(ERRNUM := CLTYPENOTSPOOLEE,FIRSTPARM);          <<06914>>49830000
         RETURN;                                               <<06914>>49835000
      END;                                                     <<06914>>49840000
                                                               <<06914>>49845000
   << check to see if device class queue is already open >>    <<06914>>49850000
      IF DCT'SPOOL'QUEUES = DCT'OPEN THEN                      <<07438>>49855000
      BEGIN   << queue is open >>                              <<06914>>49860000
         PARMNUM := 1;                                         <<06914>>49865000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>49870000
         CIERR(ERRNUM := -DEV'CL'Q'OPEN,FIRSTPARM);            <<06914>>49875000
         RETURN;                                               <<06914>>49880000
      END;                                                     <<06914>>49885000
                                                               <<06914>>49890000
   << now we can set the spoolqueues bit in DCT entry >>      <<06914>>49895000
      DCT'SPOOL'QUEUES := DCT'OPEN;                            <<06914>>49900000
      MOVETODSEG (DCT'DST, CLASS'ADDRESS, DCT, CLASS'LENGTH);  <<07438>>49905000
      <<tell ucop that queue is open>>                         <<06914>>49910000
      TELL'UCOP;                                               <<06914>>49915000
      RELSIR(DCT'SIR,SAVE'DCT'SIR);                            <<06914>>49920000
   END     << device class >>                                  <<06914>>49925000
   ELSE                                                        <<06914>>49930000
   BEGIN     << must be ldev >>                                <<06914>>49935000
      << check to see it's a real device >>                    <<06914>>49940000
      LDEV:=VERIFY'RLDEV(FIRSTPARM,LEN,ERRNUM,PARMNUM,1);      <<06914>>49945000
      IF < THEN RETURN;                                        <<06914>>49950000
      IF VERIFY'MASTEROP(LDEV) THEN RETURN;                    <<06914>>49955000
                                                               <<06914>>49960000
      << see if requestor is associated to this device, or >>  <<06914>>49965000
      << has been allowed this command.                    >>  <<06914>>49970000
      IF CHECKASS(LDEV) OR CHECKALLOW(M'OPENQ) THEN            <<06914>>49975000
      BEGIN      << user has access >>                         <<06914>>49980000
         MOVEFROMDSEG (LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY, <<07438>>49985000
                       SIZE'OF'LDT'ENTRY);                     <<07438>>49990000
                                                               <<06914>>49995000
         << see if input or output spoolable device >>         <<06914>>50000000
         IF NOT VALIDSPOOLEE (LDT'DEVICE'TYPE,                 <<07438>>50005000
            DIRECTION := OUT)                                  <<07438>>50010000
            AND NOT VALIDSPOOLEE (LDT'DEVICE'TYPE,             <<07438>>50015000
               DIRECTION := IN) THEN                           <<07438>>50020000
            BEGIN                                              <<06914>>50025000
               PARMNUM := 1;                                   <<06914>>50030000
               CIERR(ERRNUM := DEVTYPENOTSPOOLEE,FIRSTPARM);   <<06914>>50035000
               RETURN;                                         <<06914>>50040000
            END;                                               <<06914>>50045000
                                                               <<06914>>50050000
         IF DIRECTION = IN THEN                                <<06914>>50055000
         BEGIN  << can't have openq for input spoolee>>        <<06914>>50060000
            PARMNUM := 1;                                      <<06914>>50065000
            CIERR(ERRNUM := OPENQINPUT,FIRSTPARM);             <<06914>>50070000
            RETURN;                                            <<06914>>50075000
         END;                                                  <<06914>>50080000
                                                               <<06914>>50085000
      << check to see if queue is already open >>              <<06914>>50090000
      << if not, set the spool queues bit in the LDT entry >>  <<06914>>50095000
      << Refresh local LDT copy after acquiring SIR.       >>  <<07438>>50100000
         SAVE'LDT'SIR := GETSIR(LDT'SIR);                      <<06914>>50105000
         MOVEFROMDSEG(LDT, LDT'DST, LDEV*SIZE'OF'LDT'ENTRY,    <<06914>>50110000
                      SIZE'OF'LDT'ENTRY);                      <<06914>>50115000
         IF LDT'SPOOL'QUEUES = LDT'QOPEN THEN                  <<06914>>50120000
         BEGIN                                                 <<06914>>50125000
            PARMNUM := 1;                                      <<06914>>50130000
            RELSIR(LDT'SIR,SAVE'LDT'SIR);                      <<06914>>50135000
            CIERR(ERRNUM := -DEV'Q'OPEN,FIRSTPARM);            <<06914>>50140000
         END                                                   <<06914>>50145000
         ELSE                                                  <<06914>>50150000
         BEGIN   << now set queue open >>                      <<06914>>50155000
            LDT'SPOOL'QUEUES := LDT'QOPEN;                     <<06914>>50160000
            MOVETODSEG(LDT'DST, LDEV*SIZE'OF'LDT'ENTRY, LDT,   <<06914>>50165000
                       SIZE'OF'LDT'ENTRY);                     <<06914>>50170000
            RELSIR (LDT'SIR, SAVE'LDT'SIR);                    <<07438>>50175000
         << tell UCOP that queue is open >>                    <<06914>>50180000
         TELL'UCOP;                                            <<06914>>50185000
         END;                                                  <<06914>>50190000
      END   << if user has access to device >>                 <<06914>>50195000
      ELSE                                                     <<06914>>50200000
      BEGIN    << no access >>                                 <<06914>>50205000
         PARMNUM:=1;                                           <<06914>>50210000
         CIERR(ERRNUM:=USERNOACC2DEV,PARMSP);                  <<06914>>50215000
      END;                                                     <<06914>>50220000
   END;    << ldev >>                                          <<06914>>50225000
END;   << cxopenq >>                                           <<06914>>50230000
$PAGE "SHUTQ EXECUTOR"                                         <<06914>>50235000
                                                               <<06914>>50240000
PROCEDURE CXSHUTQ EXECUTORHEAD;                                <<06914>>50245000
BEGIN                                                          <<06914>>50250000
<<----------------------------------------------------------->><<06914>>50255000
<<                                                           >><<06914>>50260000
<<    THE SYNTAX OF THIS COMMAND IS:                         >><<06914>>50265000
<<       SHUTQ {ldev     }                                   >><<06914>>50270000
<<             {deviceclass}                                 >><<06914>>50275000
<<       WHERE ldev IS ANY SPOOLABLE DEVICE                  >><<06914>>50280000
<<             deviceclass MUST CONTAIN AT LEAST ONE         >><<06914>>50285000
<<                         SPOOLABLE DEVICE                  >><<06914>>50290000
<<                                                           >><<06914>>50295000
<<----------------------------------------------------------->><<06914>>50300000
                                                               <<06914>>50305000
   DOUBLE DL := [8/",", 8/";", 8/%15, 8/0]D;                   <<06914>>50310000
   BYTE ARRAY DL'(*)=DL;                                       <<06914>>50315000
   DOUBLE ARRAY PARM(0:1)=Q;                                   <<06914>>50320000
   BYTE POINTER FIRSTPARM=PARM, SNDPARM=PARM+2;                <<06914>>50325000
   BYTE LEN=PARM+1;                                            <<06914>>50330000
   LOGICAL LDEV;                                               <<06914>>50335000
   INTEGER NUMPARMS;                                           <<06914>>50340000
   LOGICAL ARRAY LDT(0:SIZE'OF'LDT'ENTRY - 1);                 <<06914>>50345000
   INTEGER LDT'INDEX := 0;                                     <<06914>>50350000
   LOGICAL POINTER DCT;                                        <<06914>>50355000
   INTEGER SAVE'LDT'SIR, SAVE'DCT'SIR;                         <<06914>>50360000
   INTEGER ARRAY DEVINFO(0:SIZE'OF'GETDEVINFO) = Q;            <<06914>>50365000
   EQUATE <<DIRECTION>>                                        <<06914>>50370000
          IN=0,                                                <<06914>>50375000
          OUT=1, << OUTPUT SPOOLING>>                          <<06914>>50380000
          EITHER = -1;                                         <<06914>>50385000
   INTEGER DIRECTION := EITHER;                                <<06914>>50390000
   INTEGER INFO;                                               <<06914>>50395000
   INTEGER ARRAY CLASSNAME(0:4);                               <<07438>>50400000
   BYTE ARRAY B'CLASSNAME(*) = CLASSNAME;                      <<06914>>50405000
   INTEGER ARRAY GETCLASSBUF(0:4);                             <<07438>>50410000
   INTEGER CLASS'ADDRESS, CLASS'LENGTH, NUMDEVS;               <<07438>>50415000
                                                               <<06914>>50420000
   SUBROUTINE DEF'MOVEFROMDSEG;                                <<06914>>50425000
   SUBROUTINE DEF'MOVETODSEG;                                  <<06914>>50430000
                                                               <<06914>>50435000
<< begin procedure CXSHUTQ >>                                  <<06914>>50440000
                                                               <<06914>>50445000
   LOGIMAGE( M'SHUTQ, PARMSP ); << log op command >>           <<06914>>50450000
   MYCOMMAND(PARMSP,DL',2,NUMPARMS,PARM);                      <<06914>>50455000
   ERRNUM := PARMNUM := 0;                                     <<06914>>50460000
   IF NUMPARMS = 0 THEN <<requires 1 parm>>                    <<06914>>50465000
   BEGIN                                                       <<06914>>50470000
      CIERR(ERRNUM := EXPLDEVORCLASS, PARMSP);                 <<06914>>50475000
      RETURN;                                                  <<06914>>50480000
   END                                                         <<06914>>50485000
   ELSE                                                        <<06914>>50490000
   IF LEN=0 THEN       << bad parameter >>                     <<06914>>50495000
   BEGIN                                                       <<06914>>50500000
      PARMNUM := 1;                                            <<06914>>50505000
      CIERR(ERRNUM := EXPLDEVBAD,FIRSTPARM);                   <<06914>>50510000
      RETURN;                                                  <<06914>>50515000
   END                                                         <<06914>>50520000
   ELSE                                                        <<06914>>50525000
   IF NUMPARMS > 1 THEN     << too many parms >>               <<06914>>50530000
   BEGIN                                                       <<06914>>50535000
      PARMNUM := 1;                                            <<06914>>50540000
      CIERR(ERRNUM := SHUTQ1PARM,SNDPARM);                     <<06914>>50545000
      RETURN;                                                  <<06914>>50550000
   END;                                                        <<06914>>50555000
                                                               <<06914>>50560000
  << parm seems ok.  now see if device class, then try ldev >> <<06914>>50565000
   LDEV := BINARY(FIRSTPARM,LEN);                              <<06914>>50570000
   IF < THEN                                                   <<06914>>50575000
   BEGIN  <<try class>>                                        <<06914>>50580000
      IF LEN > 8 THEN                                          <<06914>>50585000
      BEGIN  << classname too long>>                           <<06914>>50590000
         PARMNUM := 1;                                         <<06914>>50595000
         CIERR(ERRNUM := EXPDEVCLASSLONG,FIRSTPARM);           <<06914>>50600000
         RETURN;                                               <<06914>>50605000
      END;                                                     <<06914>>50610000
                                                               <<06914>>50615000
      <<determine if devclass is accessible>>                  <<06914>>50620000
      CLASSNAME := "  ";                                       <<07438>>50625000
      MOVE CLASSNAME(1) := CLASSNAME, (4);                     <<07438>>50630000
      MOVE B'CLASSNAME := FIRSTPARM, (LEN);                    <<07438>>50635000
      SAVE'DCT'SIR := GETSIR (DCT'SIR);                        <<07438>>50640000
      IF NOT GETCLASS (GETCLASSBUF, FALSE, , , CLASSNAME) THEN <<07438>>50645000
      BEGIN     << non-existent class name >>                  <<06914>>50650000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>50655000
         PARMNUM := 1;                                         <<06914>>50660000
         CIERR(ERRNUM := BADCLASSNAME,FIRSTPARM);              <<06914>>50665000
         RETURN;                                               <<06914>>50670000
      END;                                                     <<06914>>50675000
                                                               <<06914>>50680000
      IF VERIFY'MASTEROP'C(CLASSNAME) THEN                     <<06914>>50685000
      BEGIN                                                    <<06914>>50690000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>50695000
         RETURN;                                               <<06914>>50700000
      END;                                                     <<06914>>50705000
                                                               <<06914>>50710000
      << check if requestor is associator of this class,  >>   <<06914>>50715000
      << or has been allowed the use of this command      >>   <<06914>>50720000
      IF CHECKASS'CLASS(,B'CLASSNAME) OR                       <<06914>>50725000
         CHECKALLOW(M'SHUTQ) THEN                              <<06914>>50730000
      <<user has access>>                                      <<06914>>50735000
      ELSE                                                     <<06914>>50740000
      BEGIN                                                    <<06914>>50745000
         PARMNUM := 1;                                         <<06914>>50750000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>50755000
         CIERR(ERRNUM := USERNOACC2CLASS,PARMSP);              <<06914>>50760000
         RETURN;                                               <<06914>>50765000
      END;                                                     <<06914>>50770000
                                                               <<06914>>50775000
      << ok, user has access to class >>                       <<06914>>50780000
      << check if output spoolable class >>                    <<06914>>50785000
      CLASS'LENGTH := GET'DEVICE'CLASS (GETCLASSBUF(1),        <<07438>>50790000
                                        CLASS'ADDRESS);        <<07438>>50795000
      PUSH (S);   << Build DCT entry on stack.              >> <<07438>>50800000
      @DCT := TOS + 1;                                         <<07438>>50805000
      TOS := CLASS'LENGTH;                                     <<07438>>50810000
      ASSEMBLE (ADDS 0);                                       <<07438>>50815000
      MOVEFROMDSEG (DCT, DCT'DST, CLASS'ADDRESS,               <<07438>>50820000
                    CLASS'LENGTH);                             <<07438>>50825000
                                                               <<07438>>50830000
<< Valid spoolee if any device in class is valid.           >> <<07438>>50835000
                                                               <<07438>>50840000
      NUMDEVS := DCT'NUM'DEVICES - 1;                          <<07438>>50845000
      DIRECTION := OUT;                                        <<07438>>50850000
      DO BEGIN   << Don't need LDT'SIR to fetch DEVTYPE.    >> <<07438>>50855000
         MOVEFROMDSEG (LDT, LDT'DST, DCT(DCT'FIRST'LDEV        <<07438>>50860000
            + NUMDEVS) * SIZE'OF'LDT'ENTRY,                    <<07438>>50865000
            SIZE'OF'LDT'ENTRY);                                <<07438>>50870000
         END                                                   <<07438>>50875000
        UNTIL VALIDSPOOLEE (LDT'DEVICE'TYPE, DIRECTION)        <<07438>>50880000
              OR (NUMDEVS := NUMDEVS - 1) < 0;                 <<07438>>50885000
      IF NUMDEVS < 0 THEN                                      <<07438>>50890000
      BEGIN                                                    <<06914>>50895000
         PARMNUM := 1;                                         <<06914>>50900000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>50905000
         CIERR(ERRNUM := CLTYPENOTSPOOLEE,FIRSTPARM);          <<06914>>50910000
         RETURN;                                               <<06914>>50915000
      END;                                                     <<06914>>50920000
                                                               <<06914>>50925000
      << check to see if queue is already shut >>              <<06914>>50930000
      IF DCT'SPOOL'QUEUES = DCT'SHUT THEN                      <<07438>>50935000
      BEGIN  << queue is shut >>                               <<06914>>50940000
         PARMNUM := 1;                                         <<06914>>50945000
         RELSIR (DCT'SIR, SAVE'DCT'SIR);                       <<07438>>50950000
         CIERR(ERRNUM := -DEV'CL'Q'SHUT,FIRSTPARM);            <<06914>>50955000
         RETURN;                                               <<06914>>50960000
      END;                                                     <<06914>>50965000
                                                               <<06914>>50970000
      << clear the spoolqueues bit in DCT entry >>             <<06914>>50975000
      DCT'SPOOL'QUEUES := DCT'SHUT;                            <<06914>>50980000
      MOVETODSEG (DCT'DST, CLASS'ADDRESS, DCT, CLASS'LENGTH);  <<07438>>50985000
      RELSIR(DCT'SIR,SAVE'DCT'SIR);                            <<06914>>50990000
   END     << device class >>                                  <<06914>>50995000
   ELSE                                                        <<06914>>51000000
   BEGIN     << it's an ldev >>                                <<06914>>51005000
      << check to see it's a real device >>                    <<06914>>51010000
      LDEV:=VERIFY'RLDEV(FIRSTPARM,LEN,ERRNUM,PARMNUM,1);      <<06914>>51015000
      IF < THEN RETURN;                                        <<06914>>51020000
      IF VERIFY'MASTEROP(LDEV) THEN RETURN;                    <<06914>>51025000
                                                               <<06914>>51030000
      << see if requestor is associated to this device, or >>  <<06914>>51035000
      << has been allowed the use of this command          >>  <<06914>>51040000
      IF CHECKASS(LDEV) OR CHECKALLOW(M'SHUTQ) THEN            <<06914>>51045000
      BEGIN     << user has access >>                          <<06914>>51050000
         MOVEFROMDSEG (LDT, LDT'DST, LDEV * SIZE'OF'LDT'ENTRY, <<07438>>51055000
                       SIZE'OF'LDT'ENTRY);                     <<07438>>51060000
                                                               <<06914>>51065000
         << see if input or output spoolable device >>         <<06914>>51070000
         IF NOT VALIDSPOOLEE (LDT'DEVICE'TYPE,                 <<07438>>51075000
            DIRECTION := OUT)                                  <<07438>>51080000
            AND NOT VALIDSPOOLEE (LDT'DEVICE'TYPE,             <<07438>>51085000
                DIRECTION := IN) THEN                          <<07438>>51090000
            BEGIN                                              <<06914>>51095000
               PARMNUM := 1;                                   <<06914>>51100000
               CIERR(ERRNUM := DEVTYPENOTSPOOLEE,FIRSTPARM);   <<06914>>51105000
               RETURN;                                         <<06914>>51110000
            END;                                               <<06914>>51115000
                                                               <<07438>>51120000
<< Refresh local copy of LDT after acquiring SIR.           >> <<07438>>51125000
                                                               <<06914>>51130000
         SAVE'LDT'SIR := GETSIR(LDT'SIR);                      <<06914>>51135000
         MOVEFROMDSEG(LDT, LDT'DST, LDEV*SIZE'OF'LDT'ENTRY,    <<06914>>51140000
                      SIZE'OF'LDT'ENTRY);                      <<06914>>51145000
         IF LDT'SPOOL'STATE = LDT'INPUT'SPOOLED THEN           <<06914>>51150000
         BEGIN << can't shutq for input spooler >>             <<06914>>51155000
            PARMNUM := 1;                                      <<06914>>51160000
            RELSIR(LDT'SIR,SAVE'LDT'SIR);                      <<06914>>51165000
            CIERR(ERRNUM := SHUTQINPUT,FIRSTPARM);             <<06914>>51170000
            RETURN;                                            <<06914>>51175000
         END;                                                  <<06914>>51180000
                                                               <<06914>>51185000
         << check to see if queue is already shut >>           <<06914>>51190000
         << if not, clear spool queues bit in the LDT entry >> <<06914>>51195000
         IF LDT'SPOOL'QUEUES = LDT'QSHUT THEN                  <<06914>>51200000
         BEGIN                                                 <<06914>>51205000
            PARMNUM := 1;                                      <<06914>>51210000
            RELSIR(LDT'SIR, SAVE'LDT'SIR);                     <<06914>>51215000
            CIERR(ERRNUM := -DEV'Q'SHUT,FIRSTPARM);            <<06914>>51220000
         END                                                   <<06914>>51225000
         ELSE                                                  <<06914>>51230000
         BEGIN                                                 <<06914>>51235000
            << now shut the spool queue >>                     <<06914>>51240000
            LDT'SPOOL'QUEUES := LDT'QSHUT;                     <<06914>>51245000
            MOVETODSEG(LDT'DST, LDEV*SIZE'OF'LDT'ENTRY, LDT,   <<06914>>51250000
                       SIZE'OF'LDT'ENTRY);                     <<06914>>51255000
            RELSIR(LDT'SIR, SAVE'LDT'SIR);                     <<06914>>51260000
         END;                                                  <<06914>>51265000
      END                                                      <<06914>>51270000
      ELSE                                                     <<06914>>51275000
      BEGIN    << no access >>                                 <<06914>>51280000
         PARMNUM:=1;                                           <<06914>>51285000
         CIERR(ERRNUM:=USERNOACC2DEV,PARMSP);                  <<06914>>51290000
      END;                                                     <<06914>>51295000
   END;    << if ldev >>                                       <<06914>>51300000
END;   << cxshutq >>                                           <<06914>>51305000
$PAGE             "NRJE SPOOLER PROCEDURES"                    <<06915>>51310000
$CONTROL SEGMENT=SPOOLCOMS1                                    <<06915>>51315000
COMMENT:                                                       <<06915>>51320000
+-------------------------------------------------------+      <<06915>>51325000
|                                                       |      <<06915>>51330000
|             NRJE SPOOLER ACCESS ROUTINES              |      <<06915>>51335000
|                                                       |      <<06915>>51340000
+-------------------------------------------------------+      <<06915>>51345000
;                                                              <<06915>>51350000
                                                               <<06915>>51355000
                                                               <<06915>>51360000
COMMENT:                                                       <<06915>>51365000
+-------------------------------------------------------+      <<06915>>51370000
|                      |                                |      <<06915>>51375000
| WORDADDRESS          |  Algorithm                     |      <<06915>>51380000
|                      |                                |      <<06915>>51385000
| WORDADDRESS converts |  1. Shift byte address to the  |      <<06915>>51390000
| a byte address into a|     right to divide by two and |      <<06915>>51395000
| word address.        |     and convert to a word ad-  |      <<06915>>51400000
|                      |     dress.                     |      <<06915>>51405000
| Input                |                                |      <<06915>>51410000
|                      |  2. If new word address is out |      <<06915>>51415000
| BYTEADDRESS          |     of bounds (greater than z  |      <<06915>>51420000
|  byte address        |     reg.), return error by mak-|      <<06915>>51425000
|                      |     ing word address negative. |      <<06915>>51430000
| Output               |                                |      <<06915>>51435000
|                      |                                |      <<06915>>51440000
| FUNCTIONAL RETURN    |                                |      <<06915>>51445000
|  word address        |                                |      <<06915>>51450000
|                      |                                |      <<06915>>51455000
+-------------------------------------------------------+      <<06915>>51460000
END OF COMMENT;                                                <<06915>>51465000
                                                               <<06915>>51470000
LOGICAL                                                        <<06915>>51475000
PROCEDURE WORDADDRESS( BYTEADDRESS );                          <<06915>>51480000
VALUE BYTEADDRESS; INTEGER BYTEADDRESS;                        <<06915>>51485000
OPTION INTERNAL;                                               <<06915>>51490000
BEGIN                                                          <<06915>>51495000
                                                               <<06915>>51500000
<< 1. >>                                                       <<06915>>51505000
TOS := WORDADDRESS := BYTEADDRESS & LSR(1);                    <<06915>>51510000
                                                               <<06915>>51515000
<< 2. >>                                                       <<06915>>51520000
PUSH(Z);                                                       <<06915>>51525000
IF TOS > TOS THEN WORDADDRESS.(0:1) := 1;                      <<06915>>51530000
                                                               <<06915>>51535000
END; << PROCEDURE WORDADDRESS >>                               <<06915>>51540000
$PAGE                                                          <<06915>>51545000
COMMENT:                                                       <<06915>>51550000
+-------------------------------------------------------+      <<06915>>51555000
|                      |                                |      <<06915>>51560000
| DB'AT'STACK          |  Algorithm                     |      <<06915>>51565000
|                      |                                |      <<06915>>51570000
| DB'AT'STACK compares |  1. Set PCBPT to the PCB entry |      <<06915>>51575000
| the current DB with  |     of the current process.    |      <<06915>>51580000
| the caller's stack.  |                                |      <<06915>>51585000
|                      |  2. Compare the extra data     |      <<06915>>51590000
| Output               |     segment DST# field with    |      <<06915>>51595000
|                      |     stack(=0), setting         |      <<06915>>51600000
| If current DB is     |     DB'AT'STACK to true if     |      <<06915>>51605000
| at caller's stack,   |     equal, false if not.       |      <<06915>>51610000
| return value is      |                                |      <<06915>>51615000
| true.                |                                |      <<06915>>51620000
|                      |                                |      <<06915>>51625000
| If called in split   |                                |      <<06915>>51630000
| stack, returns false.|                                |      <<06915>>51635000
|                      |                                |      <<06915>>51640000
+-------------------------------------------------------+      <<06915>>51645000
END OF COMMENT;                                                <<06915>>51650000
                                                               <<06915>>51655000
LOGICAL PROCEDURE DB'AT'STACK;                                 <<06915>>51660000
   OPTION PRIVILEGED, UNCALLABLE;                              <<U7867>>51665000
                                                               <<U7867>>51670000
BEGIN                                                          <<06915>>51675000
   INTEGER PCBPT;                                              <<06915>>51680000
   LOGICAL POINTER PCB = SYSPCBINDEX;                          <<06915>>51685000
                                                               <<06915>>51690000
                                                               <<06915>>51695000
   PCBPT := CURPRC;                                            <<06915>>51700000
   IF SPCBXDSDST <> STACK THEN                                 <<06915>>51705000
      DB'AT'STACK := FALSE   << in split stack >>              <<06915>>51710000
   ELSE                                                        <<06915>>51715000
      DB'AT'STACK := TRUE;                                     <<06915>>51720000
END;   << procedure db'at'stack >>                             <<06915>>51725000
$PAGE                       "NRJE SPOOLER PROCEDURES"          <<06915>>51730000
COMMENT:                                                       <<06915>>51735000
+-------------------------------------------------------+      <<06915>>51740000
|                     |                                 |      <<06915>>51745000
| NRJECLASSINFO       |  Algorithm                      |      <<06915>>51750000
|                     |                                 |      <<06915>>51755000
| NRJECLASSINFO re-   |                                 |      <<06915>>51760000
| turns information   |  1. Return an error if called   |      <<06915>>51765000
| about a device class|     in split stack, itemscount  |      <<06915>>51770000
| in the info array in|     value is illegal, call by   |      <<06915>>51775000
| the same order that |     reference parameter is out  |      <<06915>>51780000
| information types   |     of bounds.                  |      <<06915>>51785000
| are passed in the   |                                 |      <<06915>>51790000
| items array.        |  2. Call the MPE primitive,     |      <<06915>>51795000
|                     |     GETCLASS, to obtain device  |      <<06915>>51800000
| Input               |     class information.          |      <<06915>>51805000
|                     |                                 |      <<06915>>51810000
| CLASS               |  3. For each no. in items:      |      <<06915>>51815000
|  8 characters repre-|                                 |      <<06915>>51820000
|  senting dev. class,|     check if no. is legal,      |      <<06915>>51825000
|  left justified,    |                                 |      <<06915>>51830000
|  blank filled       |     put information requested   |      <<06915>>51835000
| ITEMS               |     in corresponding info ele-  |      <<06915>>51840000
|  nos. representing  |     ment.                       |      <<06915>>51845000
|  type of information|                                 |      <<06915>>51850000
|  the procedure is to|                                 |      <<06915>>51855000
|  return             |                                 |      <<06915>>51860000
| ITEMSLEN            |                                 |      <<06915>>51865000
|  no. of elements in |                                 |      <<06915>>51870000
|  items array.       |                                 |      <<06915>>51875000
|                     |                                 |      <<06915>>51880000
| Output              |                                 |      <<06915>>51885000
|                     |                                 |      <<06915>>51890000
| INFO                |                                 |      <<06915>>51895000
|  information re-    |                                 |      <<06915>>51900000
|  quested            |                                 |      <<06915>>51905000
| STATUS              |                                 |      <<06915>>51910000
|    0- no errors     |                                 |      <<06915>>51915000
|  -12- baddb         |                                 |      <<06915>>51920000
|  -11- baditemscount |                                 |      <<06915>>51925000
|  -10- parmoutbounds |                                 |      <<06915>>51930000
|   -9- baditem       |                                 |      <<06915>>51935000
|   -8- badclassname  |                                 |      <<06915>>51940000
|                     |                                 |      <<06915>>51945000
+-------------------------------------------------------+      <<06915>>51950000
END OF COMMENT;                                                <<06915>>51955000
                                                               <<06915>>51960000
PROCEDURE  NRJECLASSINFO(  CLASS,        << INPUT  >>          <<06915>>51965000
                           ITEMS,        << INPUT  >>          <<06915>>51970000
                           ITEMSCOUNT,   << INPUT  >>          <<06915>>51975000
                           INFO,         << OUTPUT >>          <<06915>>51980000
                           STATUS        << OUTPUT >>          <<06915>>51985000
                        );                                     <<06915>>51990000
                                                               <<06915>>51995000
<<-------------------- PARAMETERS --------------------->>      <<06915>>52000000
                                                               <<06915>>52005000
VALUE         ITEMSCOUNT;                                      <<06915>>52010000
INTEGER       ITEMSCOUNT, STATUS;                              <<06915>>52015000
ARRAY         CLASS;                                           <<06915>>52020000
INTEGER ARRAY ITEMS, INFO;                                     <<06915>>52025000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>52030000
                                                               <<06915>>52035000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>52040000
                                                               <<06915>>52045000
BEGIN                                                          <<06915>>52050000
                                                               <<06915>>52055000
EQUATE NUMPARMS     =   5,                                     <<06915>>52060000
       QMARKERLEN   =   4,                                     <<06915>>52065000
       MARKERNPARMS =   NUMPARMS + QMARKERLEN;                 <<06915>>52070000
       << Maximum DB relative address of a reference   >>      <<06915>>52075000
       << parameter is one word below the location     >>      <<06915>>52080000
       << which contains value/address of 1st parameter>>      <<06915>>52085000
                                                               <<06915>>52090000
INTEGER XREG = X;                                              <<06915>>52095000
                                                               <<06915>>52100000
LOGICAL CRIT;                                                  <<06915>>52105000
                                                               <<06915>>52110000
INTEGER QMINUSPARMS   = Q - MARKERNPARMS;                      <<06915>>52115000
                                                               <<06915>>52120000
EQUATE  CLASSBUFFSIZE = 5,                                     <<06915>>52125000
        CLASSLEN      = 4;                                     <<06915>>52130000
                                                               <<06915>>52135000
ARRAY   BUFFER(0:CLASSBUFFSIZE - 1);                           <<06915>>52140000
DEFINE  CLASSINDEX  = BUFFER(1)#,                              <<06915>>52145000
        NUMDEVS     = IF LDT'MPE'VERSION = 4                   <<06915>>52150000
                      THEN BUFFER(3).(0:8)                     <<06915>>52155000
                      ELSE BUFFER(3)#,                         <<06915>>52160000
        FIRSTDEV    = IF LDT'MPE'VERSION = 4                   <<06915>>52165000
                      THEN BUFFER(3).(8:8)                     <<06915>>52170000
                      ELSE BUFFER(4)#;                         <<06915>>52175000
EQUATE  GETFIRSTDEV = FALSE;                                   <<06915>>52180000
                                                               <<06915>>52185000
INTEGER LOOK;                                                  <<06915>>52190000
                                                               <<06915>>52195000
EQUATE  ITEMMIN     = 1,                                       <<06915>>52200000
        ITEMMAX     = 3;                                       <<06915>>52205000
                                                               <<06915>>52210000
INTRINSIC QUIT, ARITRAP;                                       <<06915>>52215000
                                                               <<06915>>52220000
<<---------------------- EXIT ------------------------->>      <<06915>>52225000
<< Resetcritical.  Record reason for return.  Return   >>      <<06915>>52230000
<< from procedure.                                     >>      <<06915>>52235000
<<----------------------------------------------------->>      <<06915>>52240000
SUBROUTINE EXIT( REASON );                                     <<06915>>52245000
VALUE REASON; INTEGER REASON;                                  <<06915>>52250000
BEGIN                                                          <<06915>>52255000
                                                               <<06915>>52260000
RESETCRITICAL(CRIT);                                           <<06915>>52265000
                                                               <<06915>>52270000
ARITRAP(TRUE);                                                 <<06915>>52275000
                                                               <<06915>>52280000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>52285000
   ( REASON = BADDB                              ) THEN        <<06915>>52290000
  QUIT(REASON);                                                <<06915>>52295000
                                                               <<06915>>52300000
STATUS := REASON;                                              <<06915>>52305000
                                                               <<06915>>52310000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>52315000
                                                               <<06915>>52320000
END;  << SUBROUTINE EXIT >>                                    <<06915>>52325000
                                                               <<06915>>52330000
<<-------------------- INITIAL ------------------------>>      <<06915>>52335000
<< Set critical.  Return error if called in splitstack,>>      <<06915>>52340000
<< illegal itemscount value, or call by reference      >>      <<06915>>52345000
<< parameter is out of bounds.                         >>      <<06915>>52350000
<<----------------------------------------------------->>      <<06915>>52355000
SUBROUTINE INITIAL;                                            <<06915>>52360000
BEGIN                                                          <<06915>>52365000
                                                               <<06915>>52370000
ARITRAP(FALSE);                                                <<06915>>52375000
                                                               <<06915>>52380000
CRIT := SETCRITICAL;                                           <<06915>>52385000
                                                               <<06915>>52390000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>52395000
                                                               <<06915>>52400000
IF ITEMSCOUNT < 0 THEN EXIT(BADITEMSCOUNT);                    <<06915>>52405000
                                                               <<06915>>52410000
IF ( NOT FBNDCHK( @STATUS,          1, @QMINUSPARMS ) ) OR     <<06915>>52415000
   ( NOT FBNDCHK( @CLASS,    CLASSLEN, @QMINUSPARMS ) ) OR     <<06915>>52420000
   ( NOT FBNDCHK( @ITEMS,  ITEMSCOUNT, @QMINUSPARMS ) ) OR     <<06915>>52425000
   ( NOT FBNDCHK( @INFO,   ITEMSCOUNT, @QMINUSPARMS ) ) THEN   <<06915>>52430000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>52435000
                                                               <<06915>>52440000
END; << SUBROUTINE INITIAL >>                                  <<06915>>52445000
                                                               <<06915>>52450000
<<----------------- NRJECLASSINFO --------------------->>      <<06915>>52455000
                                                               <<06915>>52460000
                                                               <<06915>>52465000
<< 1. >>                                                       <<06915>>52470000
INITIAL;                                                       <<06915>>52475000
                                                               <<06915>>52480000
<< 2. >>                                                       <<06915>>52485000
IF NOT GETCLASS( BUFFER, GETFIRSTDEV, , , CLASS ) THEN         <<06915>>52490000
  EXIT(BADCLASS);                                              <<06915>>52495000
                                                               <<06915>>52500000
<< 3. >>                                                       <<06915>>52505000
LOOK := 0;                                                     <<06915>>52510000
                                                               <<06915>>52515000
WHILE LOOK < ITEMSCOUNT DO                                     <<06915>>52520000
BEGIN                                                          <<06915>>52525000
  IF NOT ( ITEMMIN <= ITEMS(LOOK) <= ITEMMAX )  THEN           <<06915>>52530000
    EXIT(BADITEM);                                             <<06915>>52535000
                                                               <<06915>>52540000
  CASE *ITEMS(LOOK) OF                                         <<06915>>52545000
  BEGIN                                                        <<06915>>52550000
    BEGIN END;                                                 <<06915>>52555000
    INFO(LOOK) := CLASSINDEX;                                  <<06915>>52560000
    INFO(LOOK) := NUMDEVS;                                     <<06915>>52565000
    INFO(LOOK) := FIRSTDEV;                                    <<06915>>52570000
  END;                                                         <<06915>>52575000
                                                               <<06915>>52580000
  LOOK := LOOK + 1;                                            <<06915>>52585000
END;                                                           <<06915>>52590000
                                                               <<06915>>52595000
EXIT(OK);                                                      <<06915>>52600000
                                                               <<06915>>52605000
END; << PROCEDURE NRJECLASSINFO >>                             <<06915>>52610000
$PAGE                                                          <<06915>>52615000
COMMENT:                                                       <<06915>>52620000
+-------------------------------------------------------+      <<06915>>52625000
|                      |                                |      <<06915>>52630000
| NRJEDEVINFO/DEVINFO  |  Algorithm                     |      <<06915>>52635000
|                      |                                |      <<06915>>52640000
| NRJEDEVINFO/DEFINFO  |  1. Return error if called in  |      <<06915>>52645000
| returns information  |     split stack, illegal items-|      <<06915>>52650000
| about a device in the|     count value, call by refer-|      <<06915>>52655000
| info array in the or-|     ence parameter out of      |      <<06915>>52660000
| er the information   |     bounds, or device not con- |      <<06915>>52665000
| types are passed in  |     figured.  If NRJEDEVINFO   |      <<06915>>52670000
| the items array.     |     call, get odd, ldt, and    |      <<06915>>52675000
| NRJEDEVINFO gets LDT,|     lpdt sirs.  Also, if NRJE- |      <<06915>>52680000
| LPDT, and ODD SIRS.  |     DEVINFO call, return an    |      <<06915>>52685000
| Also, it checks that |     error if device is not an  |      <<06915>>52690000
| the dev. about which |     NRJE reader.               |      <<06915>>52695000
| information is re-   |                                |      <<06915>>52700000
| quested is an NRJE   |                                |      <<06915>>52705000
| reader. DEVINFO does |                                |      <<06915>>52710000
| not get sirs or check|                                |      <<06915>>52715000
| the device type or   |                                |      <<06915>>52720000
| subtype.             |                                |      <<06915>>52725000
|                      |  2. For each no. in items:     |      <<06915>>52730000
| Input                |                                |      <<06915>>52735000
|                      |     check if no. is legal,     |      <<06915>>52740000
| DEVICE               |                                |      <<06915>>52745000
|  no. of an MPE log-  |     put information requested  |      <<06915>>52750000
|  ical device         |     in corresponding element of|      <<06915>>52755000
| ITEMS                |     info array.                |      <<06915>>52760000
|  nos. representing   |                                |      <<06915>>52765000
|  types  of info to   |     (All info except fences    |      <<06915>>52770000
|  return              |     from lpdt and ldt entries. |      <<06915>>52775000
| ITEMSCOUNT           |     The first time info from   |      <<06915>>52780000
|  no. of elements pas-|     ldt or lpdt requested,     |      <<06915>>52785000
|  sed in items array  |     calls MPE primitive, get-  |      <<06915>>52790000
|                      |     devinfo to obtain entries. |      <<06915>>52795000
| Output               |     Fences obtained by ex-     |      <<06915>>52800000
|                      |     changing DB and getting    |      <<06915>>52805000
| INFO                 |     fences from odd.)          |      <<06915>>52810000
|  contains info re-   |                                |      <<06915>>52815000
|  quested in items    |     BEFORE CALLING DEVINFO,    |      <<06915>>52820000
| STATUS               |     THE CALLER MUST OBTAIN THE |      <<06915>>52825000
|    0- no errors      |     LDT, LPDT, AND ODD SIRS.   |      <<06915>>52830000
|  -12- baddb          |                                |      <<06915>>52835000
|  -11- baditemscount  |     NRJEDEVINFO OBTAINS THESE  |      <<06915>>52840000
|  -10- parmoutbounds  |     SIRS FOR THE CALLER.       |      <<06915>>52845000
|   -9- baditem        |                                |      <<06915>>52850000
|   -7- baddev         |                                |      <<06915>>52855000
|   -3- devhasnofence  |                                |      <<06915>>52860000
|                      |                                |      <<06915>>52865000
+-------------------------------------------------------+      <<06915>>52870000
END OF COMMENT;                                                <<06915>>52875000
                                                               <<06915>>52880000
PROCEDURE  DEVINFO(  DEVICE,       << INPUT  >>                <<06915>>52885000
                     ITEMS,        << INPUT  >>                <<06915>>52890000
                     ITEMSCOUNT,   << INPUT  >>                <<06915>>52895000
                     INFO,         << OUTPUT >>                <<06915>>52900000
                     STATUS        << OUTPUT >>                <<06915>>52905000
                  );                                           <<06915>>52910000
                                                               <<06915>>52915000
<<-------------------- PARAMETERS --------------------->>      <<06915>>52920000
                                                               <<06915>>52925000
VALUE         DEVICE, ITEMSCOUNT;                              <<06915>>52930000
INTEGER       DEVICE, ITEMSCOUNT, STATUS;                      <<06915>>52935000
INTEGER ARRAY ITEMS, INFO;                                     <<06915>>52940000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>52945000
                                                               <<06915>>52950000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>52955000
                                                               <<06915>>52960000
BEGIN                                                          <<06915>>52965000
                                                               <<06915>>52970000
EQUATE  NUMPARMS    = 5,                                       <<06915>>52975000
        QMARKERLEN  = 4,                                       <<06915>>52980000
        MARKERNPARMS= NUMPARMS + QMARKERLEN;                   <<06915>>52985000
        << Maximum DB relative address of a reference  >>      <<06915>>52990000
        << parameter is one word below the location    >>      <<06915>>52995000
        << which contains value/address of 1st parm.   >>      <<06915>>53000000
                                                               <<06915>>53005000
INTEGER XREG = X;                                              <<06915>>53010000
                                                               <<06915>>53015000
LOGICAL CRIT;                                                  <<06915>>53020000
                                                               <<06915>>53025000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>53030000
                                                               <<06915>>53035000
ENTRY   NRJEDEVINFO;                                           <<06915>>53040000
                                                               <<06915>>53045000
LOGICAL DEVINFOCALL := FALSE;                                  <<06915>>53050000
                                                               <<06915>>53055000
LOGICAL SAVELDTSIR,                                            <<06915>>53060000
        SAVELPDTSIR,                                           <<06915>>53065000
        SAVEODDSIR;                                            <<06915>>53070000
                                                               <<06915>>53075000
EQUATE  GETDEVINFOBASE = 2,                                    <<06915>>53080000
        BUFFSIZE       = GETDEVINFOBASE    +                   <<06915>>53085000
                         SIZE'OF'LDT'ENTRY +                   <<06915>>53090000
                         SIZE'OF'LPDT'ENTRY,                   <<06915>>53095000
        BUFFLDTINDEX   = GETDEVINFOBASE + SIZE'OF'LPDT'ENTRY,  <<06915>>53100000
        BUFFLPDTINDEX  = GETDEVINFOBASE;                       <<06915>>53105000
ARRAY   BUFFER(0:BUFFSIZE - 1);                                <<06915>>53110000
                                                               <<06915>>53115000
EQUATE  BASE'LDT'TABLE  = 0,                                   <<06915>>53120000
        BASE'LPDT'TABLE = 0;                                   <<06915>>53125000
                                                               <<06915>>53130000
INTEGER LDT'INDEX, LPDT'INDEX;                                 <<06915>>53135000
INTEGER POINTER XDD'HEAD;                                      <<06915>>53140000
INTEGER POINTER LDT;                                           <<B7518>>53145000
                                                               <<06915>>53150000
EQUATE  DISKORNULLTYPE = 0;                                    <<06915>>53155000
                                                               <<06915>>53160000
INTEGER ARRAY   XDD(*) = DB + 0;                               <<06915>>53165000
                                                               <<06915>>53170000
INTEGER LOOK;                                                  <<06915>>53175000
LOGICAL HAVEDEVOUTFENCE, HAVESYSOUTFENCE, HAVEDEVSTUFF;        <<06915>>53180000
                                                               <<06915>>53185000
INTEGER DEVOUTFENCE, SYSOUTFENCE;                              <<06915>>53190000
                                                               <<06915>>53195000
EQUATE     DEVSTRSIZE = 3;                                     <<06915>>53200000
BYTE ARRAY DEVICESTRING(0:DEVSTRSIZE - 1);                     <<06915>>53205000
                                                               <<06915>>53210000
EQUATE  RIGHTJUSTIFYBASE10 = -10;                              <<06915>>53215000
                                                               <<06915>>53220000
EQUATE  ITEMMIN     = 1,                                       <<06915>>53225000
        ITEMMAX     = 12;                                      <<06915>>53230000
                                                               <<06915>>53235000
DEFINE  GETFILEUSECOUNT    =                                   <<06915>>53240000
        BEGIN                                                  <<06915>>53245000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53250000
        INFO(LOOK) := LDT'FILE'USE'CNT;                        <<06915>>53255000
        END#,                                                  <<06915>>53260000
                                                               <<06915>>53265000
        GETMAINPIN         =                                   <<06915>>53270000
        BEGIN                                                  <<06915>>53275000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53280000
        INFO(LOOK) := LDT'MAIN'PIN;                            <<06915>>53285000
        END#,                                                  <<06915>>53290000
                                                               <<06915>>53295000
        GETDEVICETYPE      =                                   <<06915>>53300000
        BEGIN                                                  <<06915>>53305000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53310000
        INFO(LOOK) := LDT'DEVICE'TYPE;                         <<06915>>53315000
        END#,                                                  <<06915>>53320000
                                                               <<06915>>53325000
        GETAVAILSYSTEM     =                                   <<06915>>53330000
        BEGIN                                                  <<06915>>53335000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53340000
        INFO(LOOK) := LDT'AVAIL'TO'SYS;                        <<06915>>53345000
        END#,                                                  <<06915>>53350000
                                                               <<06915>>53355000
        GETAVAILDIAGNOSTICS=                                   <<06915>>53360000
        BEGIN                                                  <<06915>>53365000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53370000
        INFO(LOOK) := LDT'AVAIL'TO'DIAG;                       <<06915>>53375000
        END#,                                                  <<06915>>53380000
                                                               <<06915>>53385000
        GETDOWNREQUESTED   =                                   <<06915>>53390000
        BEGIN                                                  <<06915>>53395000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53400000
        INFO(LOOK) := LDT'DOWN'PENDING;                        <<06915>>53405000
        END#,                                                  <<06915>>53410000
                                                               <<06915>>53415000
        GETSPOOLQUEUE      =                                   <<06915>>53420000
        BEGIN                                                  <<06915>>53425000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53430000
        INFO(LOOK) := LDT'SPOOL'QUEUES;                        <<06915>>53435000
        END#,                                                  <<06915>>53440000
                                                               <<06915>>53445000
        GETVIRTUALDEVDIR   =                                   <<06915>>53450000
        BEGIN                                                  <<06915>>53455000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53460000
        INFO(LOOK) := LDT'XDD'HEAD'INDEX;                      <<06915>>53465000
        END#,                                                  <<06915>>53470000
                                                               <<06915>>53475000
        GETDEVRECOGNITION  =                                   <<06915>>53480000
        BEGIN                                                  <<06915>>53485000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53490000
        INFO(LOOK) := LPDT'DEV'OWN'STATE;                      <<06915>>53495000
        END#,                                                  <<06915>>53500000
                                                               <<06915>>53505000
        GETDEVSUBTYPE      =                                   <<06915>>53510000
        BEGIN                                                  <<06915>>53515000
        IF NOT HAVEDEVSTUFF THEN GETDEVSTUFF;                  <<06915>>53520000
        INFO(LOOK) := LPDT'SUBTYPE;                            <<06915>>53525000
        END#;                                                  <<06915>>53530000
                                                               <<06915>>53535000
INTRINSIC ASCII, QUIT, ARITRAP;                                <<06915>>53540000
                                                               <<06915>>53545000
<<-------------------- EXIT --------------------------->>      <<06915>>53550000
<< Reset critical.  Record reason for return.  Return  >>      <<06915>>53555000
<< from procedure.                                     >>      <<06915>>53560000
<<----------------------------------------------------->>      <<06915>>53565000
SUBROUTINE EXIT( REASON );                                     <<06915>>53570000
VALUE REASON; INTEGER REASON;                                  <<06915>>53575000
BEGIN                                                          <<06915>>53580000
                                                               <<06915>>53585000
IF NOT DEVINFOCALL THEN                                        <<06915>>53590000
BEGIN                                                          <<06915>>53595000
  RELSIR( ODD'SIR, SAVEODDSIR );                               <<06915>>53600000
  RELSIR( LPDT'SIR, SAVELPDTSIR );                             <<06915>>53605000
  RELSIR( LDT'SIR, SAVELDTSIR );                               <<06915>>53610000
END;                                                           <<06915>>53615000
                                                               <<06915>>53620000
RESETCRITICAL(CRIT);                                           <<06915>>53625000
                                                               <<06915>>53630000
ARITRAP(TRUE);                                                 <<06915>>53635000
                                                               <<06915>>53640000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>53645000
   ( STATUS = BADDB                              ) THEN        <<06915>>53650000
  QUIT(REASON);                                                <<06915>>53655000
                                                               <<06915>>53660000
STATUS := REASON;                                              <<06915>>53665000
                                                               <<06915>>53670000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>53675000
                                                               <<06915>>53680000
END;  << SUBROUTINE EXIT >>                                    <<06915>>53685000
                                                               <<06915>>53690000
<<-------------------- INITIAL ------------------------>>      <<06915>>53695000
<< Set critical.  Return error if called in split stack>>      <<06915>>53700000
<< mode, illegal itemscount value, reference parameter >>      <<06915>>53705000
<< out of bounds, or device not configured.  If NRJE-  >>      <<06915>>53710000
<< DEVINFO call, get LDT, LPDT, and ODD sirs.  Also,   >>      <<06915>>53715000
<< if NRJEDEVINFO call, return error if device is not  >>      <<06915>>53720000
<< and NRJE reader.                                    >>      <<06915>>53725000
<<----------------------------------------------------->>      <<06915>>53730000
SUBROUTINE INITIAL;                                            <<06915>>53735000
BEGIN                                                          <<06915>>53740000
                                                               <<06915>>53745000
ARITRAP(FALSE);                                                <<06915>>53750000
                                                               <<06915>>53755000
CRIT := SETCRITICAL;                                           <<06915>>53760000
                                                               <<06915>>53765000
IF NOT DEVINFOCALL THEN                                        <<06915>>53770000
BEGIN                                                          <<06915>>53775000
  SAVELDTSIR := GETSIR(LDT'SIR);                               <<06915>>53780000
  SAVELPDTSIR := GETSIR(LPDT'SIR);                             <<06915>>53785000
  SAVEODDSIR := GETSIR(ODD'SIR);                               <<06915>>53790000
END;                                                           <<06915>>53795000
                                                               <<06915>>53800000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>53805000
                                                               <<06915>>53810000
IF ITEMSCOUNT < 0 THEN EXIT(BADITEMSCOUNT);                    <<06915>>53815000
                                                               <<06915>>53820000
IF ( NOT FBNDCHK( @STATUS,          1, @QMINUSPARMS ) ) OR     <<06915>>53825000
   ( NOT FBNDCHK( @ITEMS,  ITEMSCOUNT, @QMINUSPARMS ) ) OR     <<06915>>53830000
   ( NOT FBNDCHK( @INFO,   ITEMSCOUNT, @QMINUSPARMS ) ) THEN   <<06915>>53835000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>53840000
                                                               <<06915>>53845000
IF DEVICE < LDEVMIN THEN EXIT(BADDEV);                         <<06915>>53850000
                                                               <<06915>>53855000
@LDT  := BASE'LDT'TABLE;                                       <<06915>>53860000
LDT'INDEX := DEVICE * SIZE'OF'LDT'ENTRY;                       <<06915>>53865000
EXCHANGEDB(LDT'DST);                                           <<06915>>53870000
                                                               <<06915>>53875000
IF DEVICE > LDT'NUM'ENTRIES THEN                               <<06915>>53880000
BEGIN                                                          <<06915>>53885000
  EXCHANGEDB(0);                                               <<06915>>53890000
  EXIT(BADDEV);                                                <<06915>>53895000
END;                                                           <<06915>>53900000
                                                               <<06915>>53905000
IF (LDT'DEVICE'TYPE = DISKORNULLTYPE) AND                      <<06915>>53910000
   (LDT'RECORD'WIDTH  = 0           ) THEN                     <<06915>>53915000
BEGIN                                                          <<06915>>53920000
  EXCHANGEDB(0);                                               <<06915>>53925000
  EXIT(BADDEV);                                                <<06915>>53930000
END;                                                           <<06915>>53935000
                                                               <<06915>>53940000
IF ( NOT DEVINFOCALL             ) AND                         <<06915>>53945000
   ( LDT'DEVICE'TYPE <> NRJETYPE ) THEN                        <<06915>>53950000
BEGIN                                                          <<06915>>53955000
  EXCHANGEDB(0);                                               <<06915>>53960000
  EXIT(BADDEV);                                                <<06915>>53965000
END;                                                           <<06915>>53970000
                                                               <<06915>>53975000
EXCHANGEDB(0);                                                 <<06915>>53980000
LDT'INDEX := BUFFLDTINDEX;                                     <<06915>>53985000
@LDT := @BUFFER;                                               <<06915>>53990000
                                                               <<06915>>53995000
LPDT'INDEX := DEVICE * SIZE'OF'LPDT'ENTRY;                     <<06915>>54000000
                                                               <<06915>>54005000
IF ( NOT DEVINFOCALL             ) AND                         <<06915>>54010000
   ( LPDT'SUBTYPE <> NRJESUBTYPE ) THEN                        <<06915>>54015000
BEGIN                                                          <<06915>>54020000
  EXIT(BADDEV);                                                <<06915>>54025000
END;                                                           <<06915>>54030000
                                                               <<06915>>54035000
                                                               <<06915>>54040000
END; << SUBROUTINE INITIAL >>                                  <<06915>>54045000
                                                               <<06915>>54050000
<<-------------------- GETDEVSTUFF --------------------->>     <<06915>>54055000
<< Call MPE primitive, getdevinfo, to obtain ldt and    >>     <<06915>>54060000
<< lpdt entries.                                        >>     <<06915>>54065000
<<------------------------------------------------------>>     <<06915>>54070000
SUBROUTINE GETDEVSTUFF;                                        <<06915>>54075000
BEGIN                                                          <<06915>>54080000
                                                               <<06915>>54085000
DEVICESTRING := "0";                                           <<06915>>54090000
MOVE DEVICESTRING(1) := DEVICESTRING, (DEVSTRSIZE - 1);        <<06915>>54095000
ASCII( DEVICE,                                                 <<06915>>54100000
       RIGHTJUSTIFYBASE10,                                     <<06915>>54105000
       DEVICESTRING( DEVSTRSIZE - 1 )                          <<06915>>54110000
     );                                                        <<06915>>54115000
IF GETDEVINFO( DEVICESTRING, BUFFER ) <> OK THEN               <<06915>>54120000
  EXIT(BADDEV);                                                <<06915>>54125000
HAVEDEVSTUFF := TRUE;                                          <<06915>>54130000
                                                               <<06915>>54135000
END;    << SUBROUTINE GETDEVSTUFF >>                           <<06915>>54140000
                                                               <<06915>>54145000
<<---------------- GETSYSOUTFENCE ---------------------->>     <<06915>>54150000
<< Go   to ODD and get  system fence.                   >>     <<06915>>54155000
<<------------------------------------------------------>>     <<06915>>54160000
SUBROUTINE GETSYSOUTFENCE;                                     <<06915>>54165000
BEGIN                                                          <<06915>>54170000
                                                               <<06915>>54175000
IF NOT HAVESYSOUTFENCE THEN                                    <<06915>>54180000
BEGIN                                                          <<06915>>54185000
  EXCHANGEDB(ODD'DST);                                         <<06915>>54190000
  SYSOUTFENCE := XDD0'SYSTEM'OUTFENCE;                         <<06915>>54195000
  EXCHANGEDB(0);                                               <<06915>>54200000
  HAVESYSOUTFENCE := TRUE;                                     <<06915>>54205000
END;                                                           <<06915>>54210000
                                                               <<06915>>54215000
INFO(LOOK) := SYSOUTFENCE;                                     <<06915>>54220000
                                                               <<06915>>54225000
END;  << SUBROUTINE GETSYSOUTFENCE >>                          <<06915>>54230000
                                                               <<06915>>54235000
<<---------------- GETDEVOUTFENCE ---------------------->>     <<06915>>54240000
<< Get index to device head entry in ODD from LDT.  Then>>     <<06915>>54245000
<< get device fence from device head entry in ODD.      >>     <<06915>>54250000
<<------------------------------------------------------>>     <<06915>>54255000
SUBROUTINE GETDEVOUTFENCE;                                     <<06915>>54260000
BEGIN                                                          <<06915>>54265000
                                                               <<06915>>54270000
IF NOT HAVEDEVOUTFENCE THEN                                    <<06915>>54275000
BEGIN                                                          <<06915>>54280000
  @LDT := BASE'LDT'TABLE;                                      <<06915>>54285000
  LDT'INDEX := DEVICE * SIZE'OF'LDT'ENTRY;                     <<06915>>54290000
  EXCHANGEDB(LDT'DST);                                         <<06915>>54295000
  @XDD'HEAD :=                                                 <<06915>>54300000
    LDT'XDD'HEAD'INDEX * SIZE'OF'XDD'HEAD;                     <<06915>>54305000
  EXCHANGEDB(ODD'DST);                                         <<06915>>54310000
  IF XDDH'LDEV = DEVICE THEN                                   <<06915>>54315000
    DEVOUTFENCE := XDDH'DEV'OUTFENCE                           <<06915>>54320000
  ELSE                                                         <<06915>>54325000
  BEGIN                                                        <<06915>>54330000
    EXCHANGEDB(0);                                             <<06915>>54335000
    EXIT(DEVHASNOFENCE);                                       <<06915>>54340000
  END;                                                         <<06915>>54345000
  EXCHANGEDB(0);                                               <<06915>>54350000
  @LDT := @BUFFER;                                             <<06915>>54355000
  LDT'INDEX := BUFFLDTINDEX;                                   <<06915>>54360000
  HAVEDEVOUTFENCE := TRUE;                                     <<06915>>54365000
END;                                                           <<06915>>54370000
                                                               <<06915>>54375000
INFO(LOOK) := DEVOUTFENCE;                                     <<06915>>54380000
                                                               <<06915>>54385000
END;  << SUBROUTINE GETDEVOUTFENCE >>                          <<06915>>54390000
                                                               <<06915>>54395000
<<--------------------- DEVINFO ----------------------->>      <<06915>>54400000
                                                               <<06915>>54405000
                                                               <<06915>>54410000
DEVINFOCALL := TRUE;                                           <<06915>>54415000
                                                               <<06915>>54420000
NRJEDEVINFO:                                                   <<06915>>54425000
                                                               <<06915>>54430000
<< 1. >>                                                       <<06915>>54435000
INITIAL;                                                       <<06915>>54440000
                                                               <<06915>>54445000
                                                               <<06915>>54450000
<< 2. >>                                                       <<06915>>54455000
HAVEDEVOUTFENCE := FALSE; HAVESYSOUTFENCE := FALSE;            <<06915>>54460000
HAVEDEVSTUFF := FALSE;                                         <<06915>>54465000
LOOK := 0;                                                     <<06915>>54470000
                                                               <<06915>>54475000
WHILE LOOK < ITEMSCOUNT DO                                     <<06915>>54480000
BEGIN                                                          <<06915>>54485000
  IF NOT ( ITEMMIN <= ITEMS(LOOK) <= ITEMMAX )  THEN           <<06915>>54490000
    EXIT(BADITEM);                                             <<06915>>54495000
                                                               <<06915>>54500000
  CASE *ITEMS(LOOK) OF                                         <<06915>>54505000
  BEGIN                                                        <<06915>>54510000
    BEGIN END;                                                 <<06915>>54515000
    GETSYSOUTFENCE;                                            <<06915>>54520000
    GETDEVOUTFENCE;                                            <<06915>>54525000
    GETFILEUSECOUNT;                                           <<06915>>54530000
    GETMAINPIN;                                                <<06915>>54535000
    GETDEVICETYPE;                                             <<06915>>54540000
    GETAVAILSYSTEM;                                            <<06915>>54545000
    GETAVAILDIAGNOSTICS;                                       <<06915>>54550000
    GETDOWNREQUESTED;                                          <<06915>>54555000
    GETSPOOLQUEUE;                                             <<06915>>54560000
    GETVIRTUALDEVDIR;                                          <<06915>>54565000
    GETDEVRECOGNITION;                                         <<06915>>54570000
    GETDEVSUBTYPE;                                             <<06915>>54575000
  END;                                                         <<06915>>54580000
                                                               <<06915>>54585000
  LOOK := LOOK + 1;                                            <<06915>>54590000
END;                                                           <<06915>>54595000
                                                               <<06915>>54600000
EXIT(OK);                                                      <<06915>>54605000
                                                               <<06915>>54610000
END;  << PROCEDURE DEVINFO >>                                  <<06915>>54615000
$PAGE                                                          <<06915>>54620000
COMMENT:                                                       <<06915>>54625000
+-------------------------------------------------------+      <<06915>>54630000
|                       |                               |      <<06915>>54635000
| NRJEDEVALTER/DEVALTER | Algorithm                     |      <<06915>>54640000
|                       |                               |      <<06915>>54645000
| NRJEDEVALTER/DEVALTER |                               |      <<06915>>54650000
| modify device charac- | 1. Return error if called in  |      <<06915>>54655000
| teristics according to|    split stack mode, illegal  |      <<06915>>54660000
| the data in the new-  |    itemscount value, call by  |      <<06915>>54665000
| values array.  Modifi-|    reference parameter is out |      <<06915>>54670000
| cations are made in   |    of bounds, or device is not|      <<06915>>54675000
| the same order that   |    NRJE reader.  If NRJEDEV-  |      <<06915>>54680000
| characteristic types  |    ALTER call, obtain LDT,    |      <<06915>>54685000
| are passed in the     |    LPDT, and ODD sirs.        |      <<06915>>54690000
| items array.  NRJEDEV-|                               |      <<06915>>54695000
| ALTER obtains the LDT,|                               |      <<06915>>54700000
| LPDT, and ODD SIRS for|                               |      <<06915>>54705000
| the caller.  DEVALTER |                               |      <<06915>>54710000
| does not.             |                               |      <<06915>>54715000
|                       |                               |      <<06915>>54720000
|                       |                               |      <<06915>>54725000
|                       | 2. For each no. in items:     |      <<06915>>54730000
| Input                 |                               |      <<06915>>54735000
|                       |    check if no. is legal,     |      <<06915>>54740000
| DEVICE                |                               |      <<06915>>54745000
|  no. of an MPE logical|    check if corresponding no. |      <<06915>>54750000
|  device               |    in newvalues is legal,     |      <<06915>>54755000
| ITEMS                 |                               |      <<06915>>54760000
|  nos. representing de-|    modify corresponding device|      <<06915>>54765000
|  vice characteristics |    characteristic.            |      <<06915>>54770000
|  the procedure is to  |                               |      <<06915>>54775000
|  modify               |    (To change device charac-  |      <<06915>>54780000
| ITEMSCOUNT            |    teristics stored in odd    |      <<06915>>54785000
|  no. of elements in   |    or lpdt exchangedb and     |      <<06915>>54790000
|  items array          |    modify table entries.  To  |      <<06915>>54795000
| NEWVALUES             |    change device characteris- |      <<06915>>54800000
|  new values of char-  |    tics stored in ldt, call   |      <<06915>>54805000
|  acteristics specified|    MPE primitive,  getdev, to |      <<06915>>54810000
|  in items array       |    get entry.  Make consecu-  |      <<06915>>54815000
|                       |    tive LDT modifications.    |      <<06915>>54820000
|                       |    Call putdev primitive to   |      <<06915>>54825000
| Output                |    restore entry in ldt.)     |      <<06915>>54830000
|                       |                               |      <<06915>>54835000
|  STATUS               |    BEFORE CALLING DEVALTER,   |      <<06915>>54840000
|   no errors      - 0  |    THE USER SHOULD OBTAIN THE |      <<06915>>54845000
|   parmoutbounds  - -10|    LDT, LPDT, AND ODD SIRS.   |      <<06915>>54850000
|   baditemscount  - -11|                               |      <<06915>>54855000
|   baddev         - -7 |    NRJEDEVALTER WILL OBTAIN   |      <<06915>>54860000
|   badvalue       - -5 |    THESE SIRS FOR THE CALLER. |      <<06915>>54865000
|   baditem        - -9 |                               |      <<06915>>54870000
|   baddb          - -12|                               |      <<06915>>54875000
|                       |                               |      <<06915>>54880000
|                       |                               |      <<06915>>54885000
+-------------------------------------------------------+      <<06915>>54890000
END OF COMMENT;                                                <<06915>>54895000
                                                               <<06915>>54900000
PROCEDURE  DEVALTER(  DEVICE,       << INPUT  >>               <<06915>>54905000
                      ITEMS,        << INPUT  >>               <<06915>>54910000
                      ITEMSCOUNT,   << INPUT  >>               <<06915>>54915000
                      NEWVALUES,    << INPUT  >>               <<06915>>54920000
                      STATUS        << OUTPUT >>               <<06915>>54925000
                   );                                          <<06915>>54930000
                                                               <<06915>>54935000
<<-------------------- PARAMETERS --------------------->>      <<06915>>54940000
                                                               <<06915>>54945000
VALUE         DEVICE, ITEMSCOUNT;                              <<06915>>54950000
INTEGER       DEVICE, ITEMSCOUNT, STATUS;                      <<06915>>54955000
INTEGER ARRAY ITEMS, NEWVALUES;                                <<06915>>54960000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>54965000
                                                               <<06915>>54970000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>54975000
                                                               <<06915>>54980000
BEGIN                                                          <<06915>>54985000
                                                               <<06915>>54990000
EQUATE  NUMPARMS     = 5,                                      <<06915>>54995000
        QMARKERLEN   = 4,                                      <<06915>>55000000
        MARKERNPARMS = NUMPARMS + QMARKERLEN;                  <<06915>>55005000
        << Maximum DB relative address of a reference  >>      <<06915>>55010000
        << parameter is one word below the location    >>      <<06915>>55015000
        << which contains value or address of 1st parm.>>      <<06915>>55020000
                                                               <<06915>>55025000
INTEGER XREG = X;                                              <<06915>>55030000
                                                               <<06915>>55035000
LOGICAL CRIT;                                                  <<06915>>55040000
                                                               <<06915>>55045000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>55050000
                                                               <<06915>>55055000
ENTRY   NRJEDEVALTER;                                          <<06915>>55060000
                                                               <<06915>>55065000
LOGICAL DEVALTERCALL := FALSE;                                 <<06915>>55070000
                                                               <<06915>>55075000
LOGICAL SAVELDTSIR,                                            <<06915>>55080000
        SAVELPDTSIR,                                           <<06915>>55085000
        SAVEODDSIR;                                            <<06915>>55090000
                                                               <<06915>>55095000
ARRAY   BUFFER(0:SIZE'OF'LDT'ENTRY - 1) = Q;                   <<06915>>55100000
                                                               <<06915>>55105000
EQUATE  BASE'LDT'TABLE = 0;                                    <<06915>>55110000
EQUATE  BUFFLDTINDEX = 0;                                      <<06915>>55115000
                                                               <<06915>>55120000
INTEGER LPDT'INDEX;                                            <<06915>>55125000
INTEGER LDT'INDEX;                                             <<06915>>55130000
                                                               <<06915>>55135000
INTEGER POINTER LDT, LPDT = 8;                                 <<06915>>55140000
                                                               <<06915>>55145000
INTEGER POINTER XDD'HEAD;                                      <<06915>>55150000
                                                               <<06915>>55155000
INTEGER DEVRECOGNITION, DEVOUTFENCE;                           <<06915>>55160000
                                                               <<06915>>55165000
INTEGER LOOK;                                                  <<06915>>55170000
                                                               <<06915>>55175000
LOGICAL LDTTYPE;                                               <<06915>>55180000
                                                               <<06915>>55185000
LOGICAL POINTER PCB = SYSPCBINDEX;                             <<06915>>55190000
                                                               <<06915>>55195000
EQUATE  VIRTUAL     = 1;                                       <<06915>>55200000
                                                               <<06915>>55205000
EQUATE  ITEMMIN     = 1,                                       <<06915>>55210000
        ITEMMAX     = 5,                                       <<06915>>55215000
        FENCEMIN      = 0,                                     <<07333>>55220000
        FENCEMAX    = 14,                                      <<06915>>55225000
        FILEMIN     = 0,                                       <<06915>>55230000
        FILEMAX     = 1,                                       <<06915>>55235000
        PINMIN      = 0,                                       <<06915>>55240000
        SPOOLQMIN   = 0,                                       <<06915>>55245000
        SPOOLQMAX   = 1,                                       <<06915>>55250000
        DEVRECMIN   = 0,                                       <<06915>>55255000
        DEVRECMAX   = 3;                                       <<06915>>55260000
                                                               <<06915>>55265000
DEFINE                                                         <<06915>>55270000
                                                               <<06915>>55275000
  << total # of configured PCB entries >>                      <<06915>>55280000
  PINMAX = integer(PCB(0))#,                                   <<06915>>55285000
                                                               <<06915>>55290000
  MOVEFILECOUNT    =                                           <<06915>>55295000
  IF FILEMIN <= NEWVALUES(LOOK) <= FILEMAX THEN                <<06915>>55300000
    LDT'FILE'USE'CNT := NEWVALUES(LOOK)                        <<06915>>55305000
  ELSE EXIT(BADVALUE)#,                                        <<06915>>55310000
                                                               <<06915>>55315000
  MOVEMAINPIN      =                                           <<06915>>55320000
  IF PINMIN <= NEWVALUES(LOOK) <= PINMAX THEN                  <<06915>>55325000
    LDT'MAIN'PIN := NEWVALUES(LOOK)                            <<06915>>55330000
  ELSE EXIT(BADVALUE)#,                                        <<06915>>55335000
                                                               <<06915>>55340000
  MOVESPOOLQS      =                                           <<06915>>55345000
  IF SPOOLQMIN<=NEWVALUES(LOOK) <= SPOOLQMAX THEN              <<06915>>55350000
    LDT'SPOOL'QUEUES := NEWVALUES(LOOK)                        <<06915>>55355000
  ELSE EXIT(BADVALUE)#;                                        <<06915>>55360000
                                                               <<06915>>55365000
INTRINSIC QUIT, ARITRAP;                                       <<06915>>55370000
                                                               <<06915>>55375000
<<---------------------- EXIT ------------------------->>      <<06915>>55380000
<< Reset critical.  Record reason for return.  Return  >>      <<06915>>55385000
<< from procedure.                                     >>      <<06915>>55390000
<<----------------------------------------------------->>      <<06915>>55395000
SUBROUTINE EXIT( REASON );                                     <<06915>>55400000
VALUE REASON; INTEGER REASON;                                  <<06915>>55405000
BEGIN                                                          <<06915>>55410000
                                                               <<06915>>55415000
IF NOT DEVALTERCALL THEN                                       <<06915>>55420000
BEGIN                                                          <<06915>>55425000
  RELSIR( ODD'SIR, SAVEODDSIR );                               <<06915>>55430000
  RELSIR( LPDT'SIR, SAVELPDTSIR );                             <<06915>>55435000
  RELSIR( LDT'SIR, SAVELDTSIR );                               <<06915>>55440000
END;                                                           <<06915>>55445000
                                                               <<06915>>55450000
RESETCRITICAL(CRIT);                                           <<06915>>55455000
                                                               <<06915>>55460000
ARITRAP(TRUE);                                                 <<06915>>55465000
                                                               <<06915>>55470000
IF ( NOT FBNDCHK( @STATUS,          1, @QMINUSPARMS ) ) OR     <<06915>>55475000
   ( STATUS = BADDB                              ) THEN        <<06915>>55480000
  QUIT(REASON);                                                <<06915>>55485000
                                                               <<06915>>55490000
STATUS := REASON;                                              <<06915>>55495000
                                                               <<06915>>55500000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>55505000
                                                               <<06915>>55510000
END;  << SUBROUTINE EXIT >>                                    <<06915>>55515000
                                                               <<06915>>55520000
<<-------------------- INITIAL ------------------------>>      <<06915>>55525000
<< Set critical.  Return error if called in split stack>>      <<06915>>55530000
<< mode, illegal itemscount value, reference parameter >>      <<06915>>55535000
<< is out of bounds, or device is not NRJE reader.     >>      <<06915>>55540000
<<----------------------------------------------------->>      <<06915>>55545000
SUBROUTINE INITIAL;                                            <<06915>>55550000
BEGIN                                                          <<06915>>55555000
                                                               <<06915>>55560000
ARITRAP(FALSE);                                                <<06915>>55565000
                                                               <<06915>>55570000
CRIT := SETCRITICAL;                                           <<06915>>55575000
                                                               <<06915>>55580000
IF NOT( DEVALTERCALL ) THEN                                    <<06915>>55585000
BEGIN                                                          <<06915>>55590000
  SAVELDTSIR  := GETSIR(LDT'SIR);                              <<06915>>55595000
  SAVELPDTSIR := GETSIR(LPDT'SIR);                             <<06915>>55600000
  SAVEODDSIR  := GETSIR(ODD'SIR);                              <<06915>>55605000
END;                                                           <<06915>>55610000
                                                               <<06915>>55615000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>55620000
                                                               <<06915>>55625000
IF ITEMSCOUNT < 0 THEN EXIT(BADITEMSCOUNT);                    <<06915>>55630000
                                                               <<06915>>55635000
IF ( NOT FBNDCHK( @STATUS,             1, @QMINUSPARMS ) ) OR  <<06915>>55640000
   ( NOT FBNDCHK( @ITEMS,     ITEMSCOUNT, @QMINUSPARMS ) ) OR  <<06915>>55645000
   ( NOT FBNDCHK( @NEWVALUES, ITEMSCOUNT, @QMINUSPARMS ) ) THEN<<06915>>55650000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>55655000
                                                               <<06915>>55660000
IF DEVICE < LDEVMIN THEN EXIT(BADDEV);                         <<06915>>55665000
                                                               <<06915>>55670000
@LDT := BASE'LDT'TABLE;                                        <<06915>>55675000
LDT'INDEX  := DEVICE * SIZE'OF'LDT'ENTRY;                      <<06915>>55680000
LPDT'INDEX := DEVICE * SIZE'OF'LPDT'ENTRY;                     <<06915>>55685000
                                                               <<06915>>55690000
IF DEVICE > LPDT'MAX'ENTRIES        OR                         <<06915>>55695000
   LPDT'VIRTUAL'DEVICE = VIRTUAL    OR                         <<06915>>55700000
   LPDT'SUBTYPE <> NRJESUBTYPE      THEN                       <<06915>>55705000
  EXIT(BADDEV);                                                <<06915>>55710000
                                                               <<06915>>55715000
EXCHANGEDB(LDT'DST);                                           <<06915>>55720000
IF LDT'DEVICE'TYPE <> NRJETYPE THEN                            <<06915>>55725000
BEGIN                                                          <<06915>>55730000
  EXCHANGEDB(0);                                               <<06915>>55735000
  EXIT(BADDEV);                                                <<06915>>55740000
END;                                                           <<06915>>55745000
EXCHANGEDB(0);                                                 <<06915>>55750000
                                                               <<06915>>55755000
END; << SUBROUTINE INITIAL >>                                  <<06915>>55760000
                                                               <<06915>>55765000
<<------------------- PUTODD -------------------------->>      <<06915>>55770000
<< Check for illegal new value of device fence.  Get   >>      <<06915>>55775000
<< index to device head entry in odd from ldt.  Then,  >>      <<06915>>55780000
<< modify device fence in device head entry of odd.    >>      <<06915>>55785000
<<----------------------------------------------------->>      <<06915>>55790000
SUBROUTINE PUTODD;                                             <<06915>>55795000
BEGIN                                                          <<06915>>55800000
                                                               <<06915>>55805000
IF NOT ( FENCEMIN <= NEWVALUES(LOOK) <= FENCEMAX ) THEN        <<06915>>55810000
  EXIT(BADVALUE);                                              <<06915>>55815000
                                                               <<06915>>55820000
DEVOUTFENCE := NEWVALUES(LOOK);                                <<06915>>55825000
@LDT := BASE'LDT'TABLE;                                        <<06915>>55830000
LDT'INDEX := DEVICE * SIZE'OF'LDT'ENTRY;                       <<06915>>55835000
EXCHANGEDB(LDT'DST);                                           <<06915>>55840000
@XDD'HEAD := LDT'XDD'HEAD'INDEX * SIZE'OF'XDD'HEAD;            <<06915>>55845000
EXCHANGEDB(ODD'DST);                                           <<06915>>55850000
XDDH'DEV'OUTFENCE := DEVOUTFENCE;                              <<06915>>55855000
EXCHANGEDB(0);                                                 <<06915>>55860000
LOOK := LOOK + 1;                                              <<06915>>55865000
                                                               <<06915>>55870000
END;  << SUBROUTINE PUTODD >>                                  <<06915>>55875000
                                                               <<06915>>55880000
<<-------------------- PUTLDT ------------------------->>      <<06915>>55885000
<< Call getdev, MPE primitive, to get ldt entry for de->>      <<06915>>55890000
<< vice.  Put consecutive ldt item values in entry.    >>      <<06915>>55895000
<< Call putdev primitive to put entry back in ldt.     >>      <<06915>>55900000
<<----------------------------------------------------->>      <<06915>>55905000
SUBROUTINE PUTLDT;                                             <<06915>>55910000
BEGIN                                                          <<06915>>55915000
                                                               <<06915>>55920000
IF NOT( GETDEV( DEVICE, LDT'DST, BUFFER ) ) THEN               <<06915>>55925000
  EXIT( BADDEV);                                               <<06915>>55930000
                                                               <<06915>>55935000
LDT'INDEX := BUFFLDTINDEX;                                     <<06915>>55940000
@LDT := @BUFFER;                                               <<06915>>55945000
LDTTYPE := TRUE;                                               <<06915>>55950000
                                                               <<06915>>55955000
WHILE ( LOOK < ITEMSCOUNT  ) AND                               <<06915>>55960000
      ( LDTTYPE            ) DO                                <<06915>>55965000
BEGIN                                                          <<06915>>55970000
                                                               <<06915>>55975000
  IF NOT ( ITEMMIN <= ITEMS(LOOK) <= ITEMMAX ) THEN            <<06915>>55980000
    EXIT(BADITEM);                                             <<06915>>55985000
                                                               <<06915>>55990000
  CASE *ITEMS(LOOK) OF                                         <<06915>>55995000
  BEGIN                                                        <<06915>>56000000
    BEGIN END;                                                 <<06915>>56005000
    LDTTYPE := FALSE;                                          <<06915>>56010000
    MOVEFILECOUNT;                                             <<06915>>56015000
    MOVEMAINPIN;                                               <<06915>>56020000
    MOVESPOOLQS;                                               <<06915>>56025000
    LDTTYPE := FALSE;                                          <<06915>>56030000
  END;                                                         <<06915>>56035000
                                                               <<06915>>56040000
  IF LDTTYPE THEN                                              <<06915>>56045000
    LOOK := LOOK + 1;                                          <<06915>>56050000
                                                               <<06915>>56055000
END;                                                           <<06915>>56060000
                                                               <<06915>>56065000
IF NOT ( PUTDEV( DEVICE, LDT'DST, BUFFER ) ) THEN              <<06915>>56070000
  EXIT(BADDEV);                                                <<06915>>56075000
                                                               <<06915>>56080000
END;  << SUBROUTINE PUTLDT >>                                  <<06915>>56085000
                                                               <<06915>>56090000
<<-------------------- PUTLPDT ------------------------>>      <<06915>>56095000
<< Find device entry in lpdt, exchangedb, and update   >>      <<06915>>56100000
<< device recognition state.                           >>      <<06915>>56105000
<<----------------------------------------------------->>      <<06915>>56110000
SUBROUTINE PUTLPDT;                                            <<06915>>56115000
BEGIN                                                          <<06915>>56120000
                                                               <<06915>>56125000
IF NOT ( DEVRECMIN <= NEWVALUES(LOOK) <= DEVRECMAX ) THEN      <<06915>>56130000
  EXIT(BADVALUE);                                              <<06915>>56135000
                                                               <<06915>>56140000
DEVRECOGNITION := NEWVALUES(LOOK);                             <<06915>>56145000
DISABLE;                                                       <<B7518>>56150000
LPDT'DEV'OWN'STATE := DEVRECOGNITION;                          <<06915>>56155000
ENABLE;                                                        <<B7518>>56160000
LOOK := LOOK + 1;                                              <<06915>>56165000
                                                               <<06915>>56170000
END;  << SUBROUTINE PUTLPDT >>                                 <<06915>>56175000
                                                               <<06915>>56180000
<<-------------------- DEVALTER ----------------------->>      <<06915>>56185000
                                                               <<06915>>56190000
                                                               <<06915>>56195000
DEVALTERCALL := TRUE;                                          <<06915>>56200000
                                                               <<06915>>56205000
NRJEDEVALTER:                                                  <<06915>>56210000
                                                               <<06915>>56215000
                                                               <<06915>>56220000
                                                               <<06915>>56225000
<< 1. >>                                                       <<06915>>56230000
INITIAL;                                                       <<06915>>56235000
                                                               <<06915>>56240000
                                                               <<06915>>56245000
<< 2. >>                                                       <<06915>>56250000
LOOK := 0;                                                     <<06915>>56255000
                                                               <<06915>>56260000
WHILE LOOK < ITEMSCOUNT DO                                     <<06915>>56265000
BEGIN                                                          <<06915>>56270000
  IF NOT ( ITEMMIN <= ITEMS(LOOK) <= ITEMMAX ) THEN            <<06915>>56275000
    EXIT(BADITEM);                                             <<06915>>56280000
                                                               <<06915>>56285000
  CASE *ITEMS(LOOK) OF                                         <<06915>>56290000
  BEGIN                                                        <<06915>>56295000
    BEGIN END;                                                 <<06915>>56300000
    PUTODD;                                                    <<06915>>56305000
    PUTLDT;                                                    <<06915>>56310000
    PUTLDT;                                                    <<06915>>56315000
    PUTLDT;                                                    <<06915>>56320000
    PUTLPDT;                                                   <<06915>>56325000
  END;                                                         <<06915>>56330000
                                                               <<06915>>56335000
END;                                                           <<06915>>56340000
                                                               <<06915>>56345000
EXIT(OK);                                                      <<06915>>56350000
                                                               <<06915>>56355000
END; << PROCEDURE DEVALTER >>                                  <<06915>>56360000
$PAGE                                                          <<06915>>56365000
COMMENT:                                                       <<06915>>56370000
+-------------------------------------------------------+      <<06915>>56375000
|                        |                              |      <<06915>>56380000
| NRJESPOOLINFO          | Algorithm                    |      <<06915>>56385000
|                        |                              |      <<06915>>56390000
| NRJESPOOLINFO returns  | 1. Return error if called    |      <<06915>>56395000
| information about a    |    in split stack mode, bad  |      <<06915>>56400000
| spool file in the info |    itemscount, bad string-   |      <<06915>>56405000
| array in the same order|    itemscount, reference parm|      <<06915>>56410000
| as information types   |    out of bounds, bad queue  |      <<06915>>56415000
| are passed in the items|    value, or bad index value.|      <<06915>>56420000
| array.                 |    Use queue and index values|      <<06915>>56425000
|                        |    to find address of spool  |      <<06915>>56430000
|                        |    file subentry.            |      <<06915>>56435000
| Input                  |                              |      <<06915>>56440000
|                        | 2. Get spool file subentry   |      <<06915>>56445000
|                        |    from odd.                 |      <<06915>>56450000
| QUEUE                  |                              |      <<06915>>56455000
|   odd device header in-| 3. For each no. in items:    |      <<06915>>56460000
|   dex (queue containing|     check if no. is legal,   |      <<06915>>56465000
|   spool file)          |     put info in corresponding|      <<06915>>56470000
| INDEX                  |     element of info array.   |      <<06915>>56475000
|   if 1st spool file in |                              |      <<06915>>56480000
|   queue, 1,else offset | 4. For each no. in string-   |      <<06915>>56485000
|   of subentry in odd   |    items:                    |      <<06915>>56490000
| ITEMS                  |     check if no. is legal,   |      <<06915>>56495000
|   nos. representing    |     put info in corresponding|      <<06915>>56500000
|   types of integer     |     element of stringinfo.   |      <<06915>>56505000
|   spool file info to   |                              |      <<06915>>56510000
|   be returned          |  Output                      |      <<06915>>56515000
| ITEMSCOUNT             |                              |      <<06915>>56520000
|   no. of elements in   |  INFO                        |      <<06915>>56525000
|   items array          |    integer spool file data   |      <<06915>>56530000
| STRINGITEMS            |    requested in items array  |      <<06915>>56535000
|   nos. representing    |  INFOSTRING                  |      <<06915>>56540000
|   types of character   |    character spool file data |      <<06915>>56545000
|   spool file info to be|    requested in stringitems  |      <<06915>>56550000
|   returned             |  STATUS                      |      <<06915>>56555000
| STRINGITEMSCOUNT       |    no errors            - 0  |      <<06915>>56560000
|   no. elements in      |    baditemscount        - -11|      <<06915>>56565000
|   stringitems array    |    badstringitemscount  - -4 |      <<06915>>56570000
|                        |    parmoutbounds        - -10|      <<06915>>56575000
|                        |    badqueue             - -6 |      <<06915>>56580000
|                        |    nospoolfiles         - -14|      <<06915>>56585000
|                        |    badindex             - -2 |      <<06915>>56590000
|                        |    baditem              - -9 |      <<06915>>56595000
|                        |    badstringitem        - -1 |      <<06915>>56600000
|                        |    baddb                - -12|      <<06915>>56605000
|                        |                              |      <<06915>>56610000
+-------------------------------------------------------+      <<06915>>56615000
END OF COMMENT;                                                <<06915>>56620000
                                                               <<06915>>56625000
PROCEDURE  NRJESPOOLINFO(  QUEUE,            << INPUT  >>      <<06915>>56630000
                           INDEX,            << INPUT  >>      <<06915>>56635000
                           ITEMS,            << INPUT  >>      <<06915>>56640000
                           ITEMSCOUNT,       << INPUT  >>      <<06915>>56645000
                           STRINGITEMS,      << INPUT  >>      <<06915>>56650000
                           STRINGITEMSCOUNT, << INPUT  >>      <<06915>>56655000
                           INFO,             << OUTPUT >>      <<06915>>56660000
                           INFOSTRING,       << OUTPUT >>      <<06915>>56665000
                           STATUS            << OUTPUT >>      <<06915>>56670000
                        );                                     <<06915>>56675000
                                                               <<06915>>56680000
<<-------------------- PARAMETERS --------------------->>      <<06915>>56685000
                                                               <<06915>>56690000
VALUE         QUEUE, INDEX, ITEMSCOUNT, STRINGITEMSCOUNT;      <<06915>>56695000
INTEGER       QUEUE, INDEX, ITEMSCOUNT, STRINGITEMSCOUNT;      <<06915>>56700000
INTEGER       STATUS;                                          <<06915>>56705000
BYTE ARRAY    INFOSTRING;                                      <<06915>>56710000
INTEGER ARRAY ITEMS, STRINGITEMS, INFO;                        <<06915>>56715000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>56720000
                                                               <<06915>>56725000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>56730000
                                                               <<06915>>56735000
BEGIN                                                          <<06915>>56740000
                                                               <<06915>>56745000
EQUATE  NUMPARMS     = 9,                                      <<06915>>56750000
        QMARKERLEN  = 4,                                       <<06915>>56755000
        MARKERNPARMS= NUMPARMS + QMARKERLEN;                   <<06915>>56760000
        << Maximum DB relative address of reference  >>        <<06915>>56765000
        << parameter is one word below the location  >>        <<06915>>56770000
        << which contains value/address of 1st parm. >>        <<06915>>56775000
                                                               <<06915>>56780000
INTEGER XREG = X;                                              <<06915>>56785000
                                                               <<06915>>56790000
LOGICAL CRIT;                                                  <<06915>>56795000
                                                               <<06915>>56800000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>56805000
                                                               <<06915>>56810000
ARRAY       XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY - 1);          <<06915>>56815000
BYTE ARRAY  XDD'BSUBENTRY(*) = XDD'SUBENTRY;                   <<06915>>56820000
                                                               <<06915>>56825000
INTEGER ARRAY   XDD(*) = DB + 0;                               <<06915>>56830000
                                                               <<06915>>56835000
INTEGER POINTER XDD'HEAD;                                      <<06915>>56840000
                                                               <<06915>>56845000
INTEGER LOOK;                                                  <<06915>>56850000
                                                               <<06915>>56855000
INTEGER QUEUEADDRESS, INDEXADDRESS;                            <<06915>>56860000
                                                               <<06915>>56865000
EQUATE  NULLDEVICE = 0;                                        <<06915>>56870000
                                                               <<06915>>56875000
EQUATE  BYTESPERSTRING=8,                                      <<06915>>56880000
        ROUNDUP       =BYTESPERWORD/2,                         <<06915>>56885000
        WORDSPERSTRING=(BYTESPERSTRING+ROUNDUP)/               <<06915>>56890000
                       BYTESPERWORD;                           <<06915>>56895000
                                                               <<06915>>56900000
EQUATE  ITEMMIN           = 1,                                 <<06915>>56905000
        ITEMMAX           = 12,                                <<06915>>56910000
        STRINGITEMMIN     = 1,                                 <<06915>>56915000
        STRINGITEMMAX     = 3;                                 <<06915>>56920000
                                                               <<06915>>56925000
INTRINSIC QUIT, ARITRAP;                                       <<06915>>56930000
                                                               <<06915>>56935000
<<---------------------- EXIT ------------------------->>      <<06915>>56940000
<< Reset critical.  Record reason for return.  Return  >>      <<06915>>56945000
<< from procedure.                                     >>      <<06915>>56950000
<<----------------------------------------------------->>      <<06915>>56955000
SUBROUTINE EXIT( REASON );                                     <<06915>>56960000
VALUE REASON; INTEGER REASON;                                  <<06915>>56965000
BEGIN                                                          <<06915>>56970000
                                                               <<06915>>56975000
RESETCRITICAL(CRIT);                                           <<06915>>56980000
                                                               <<06915>>56985000
ARITRAP(TRUE);                                                 <<06915>>56990000
                                                               <<06915>>56995000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>57000000
   ( STATUS = BADDB                              ) THEN        <<06915>>57005000
  QUIT(REASON);                                                <<06915>>57010000
                                                               <<06915>>57015000
STATUS := REASON;                                              <<06915>>57020000
                                                               <<06915>>57025000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>57030000
                                                               <<06915>>57035000
END;  << SUBROUTINE EXIT >>                                    <<06915>>57040000
                                                               <<06915>>57045000
<<-------------------- INITIAL ------------------------>>      <<06915>>57050000
<< Set critical.  Return error if called in split stack>>      <<06915>>57055000
<< mode, illegal itemscount or stringitemscount value, >>      <<06915>>57060000
<< reference parameter out of bounds, illegal queue    >>      <<06915>>57065000
<< value, or illegal index value.  Use queu and index  >>      <<06915>>57070000
<< values to find address of spool file subentry.      >>      <<06915>>57075000
<<----------------------------------------------------->>      <<06915>>57080000
SUBROUTINE INITIAL;                                            <<06915>>57085000
BEGIN                                                          <<06915>>57090000
                                                               <<06915>>57095000
ARITRAP(FALSE);                                                <<06915>>57100000
                                                               <<06915>>57105000
CRIT := SETCRITICAL;                                           <<06915>>57110000
                                                               <<06915>>57115000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>57120000
                                                               <<06915>>57125000
IF ITEMSCOUNT < 0 THEN EXIT(BADITEMSCOUNT);                    <<06915>>57130000
IF STRINGITEMSCOUNT < 0 THEN EXIT(BADSTRINGITEMSCOUNT);        <<06915>>57135000
                                                               <<06915>>57140000
IF ( NOT FBNDCHK( @STATUS,          1, @QMINUSPARMS ) ) OR     <<06915>>57145000
   ( NOT FBNDCHK( @ITEMS,  ITEMSCOUNT, @QMINUSPARMS ) ) OR     <<06915>>57150000
   ( NOT FBNDCHK( @INFO,   ITEMSCOUNT, @QMINUSPARMS ) ) OR     <<06915>>57155000
   ( NOT FBNDCHK( @STRINGITEMS,                                <<06915>>57160000
                  STRINGITEMSCOUNT,                            <<06915>>57165000
                  @QMINUSPARMS                      ) ) OR     <<06915>>57170000
   ( NOT FBNDCHK( WORDADDRESS(INFOSTRING),                     <<06915>>57175000
                  STRINGITEMSCOUNT * WORDSPERSTRING,           <<06915>>57180000
                  @QMINUSPARMS                      ) ) THEN   <<06915>>57185000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>57190000
                                                               <<06915>>57195000
IF QUEUE = CLASSQUEUE THEN QUEUEADDRESS:=XDD'CLASS'ENTRY       <<06915>>57200000
ELSE QUEUEADDRESS := QUEUE * SIZE'OF'XDD'HEAD;                 <<06915>>57205000
                                                               <<06915>>57210000
EXCHANGEDB(ODD'DST);                                           <<06915>>57215000
                                                               <<06915>>57220000
IF NOT ( XDD'CLASS'ENTRY <= QUEUEADDRESS           ) OR        <<06915>>57225000
   NOT ( QUEUEADDRESS <= XDD0'SUBENTRY'AREA -                  <<06915>>57230000
                         SIZE'OF'XDD'HEAD          ) THEN      <<06915>>57235000
BEGIN                                                          <<06915>>57240000
  EXCHANGEDB(0);                                               <<06915>>57245000
  EXIT(BADQUEUE);                                              <<06915>>57250000
END;                                                           <<06915>>57255000
                                                               <<06915>>57260000
@XDD'HEAD := QUEUEADDRESS;                                     <<06915>>57265000
                                                               <<06915>>57270000
IF INDEX = FIRSTINQUEUE THEN                                   <<06915>>57275000
INDEXADDRESS := XDDH'FIRST'SUBENTRY                            <<06915>>57280000
ELSE INDEXADDRESS := INDEX;                                    <<06915>>57285000
                                                               <<06915>>57290000
IF INDEXADDRESS = NILL'LINK THEN                               <<06915>>57295000
BEGIN                                                          <<06915>>57300000
  EXCHANGEDB(0);                                               <<06915>>57305000
  EXIT(NOSPOOLFILES);                                          <<06915>>57310000
END;                                                           <<06915>>57315000
                                                               <<06915>>57320000
IF NOT ( XDD0'SUBENTRY'AREA <= INDEXADDRESS     ) OR           <<06915>>57325000
   NOT ( INDEXADDRESS <= XDD0'CURRENT'SECTORS *                <<06915>>57330000
                         WORDSPERSECTOR       -                <<06915>>57335000
                         SIZE'OF'XDD'SUBENTRY   ) THEN         <<06915>>57340000
BEGIN                                                          <<06915>>57345000
  EXCHANGEDB(0);                                               <<06915>>57350000
  EXIT(BADINDEX);                                              <<06915>>57355000
END;                                                           <<06915>>57360000
                                                               <<06915>>57365000
EXCHANGEDB(0);                                                 <<06915>>57370000
                                                               <<06915>>57375000
END; << SUBROUTINE INITIAL >>                                  <<06915>>57380000
                                                               <<06915>>57385000
<<----------------- GETSUBENTRY ----------------------->>      <<06915>>57390000
<< Move spool file subentry from odd to procedure's    >>      <<06915>>57395000
<< stack.  Check that subentry corresponds to queue    >>      <<06915>>57400000
<< passed by user.                                     >>      <<06915>>57405000
<<----------------------------------------------------->>      <<06915>>57410000
SUBROUTINE GETSUBENTRY;                                        <<06915>>57415000
BEGIN                                                          <<06915>>57420000
                                                               <<06915>>57425000
TOS := @XDD'SUBENTRY;                                          <<06915>>57430000
TOS := ODD'DST;                                                <<06915>>57435000
TOS := INDEXADDRESS;                                           <<06915>>57440000
TOS := SIZE'OF'XDD'SUBENTRY;                                   <<06915>>57445000
ASSEMBLE( MFDS 4 );                                            <<06915>>57450000
                                                               <<06915>>57455000
IF ( QUEUE <> INTEGER(XDDS'HEAD'INDEX)            ) OR         <<06915>>57460000
   ( INTEGER(XDDS'SPOOFLE'VT'INDEX) = NULLDEVICE  ) THEN       <<06915>>57465000
  EXIT(BADINDEX);                                              <<06915>>57470000
                                                               <<06915>>57475000
END; << SUBROUTINE GETSUBENTRY >>                              <<06915>>57480000
                                                               <<06915>>57485000
<<----------------- NRJESPOOLINFO --------------------->>      <<06915>>57490000
                                                               <<06915>>57495000
                                                               <<06915>>57500000
<< 1.  >>                                                      <<06915>>57505000
INITIAL;                                                       <<06915>>57510000
                                                               <<06915>>57515000
<< 2.  >>                                                      <<06915>>57520000
GETSUBENTRY;                                                   <<06915>>57525000
                                                               <<06915>>57530000
                                                               <<06915>>57535000
<< 3. >>                                                       <<06915>>57540000
LOOK := 0;                                                     <<06915>>57545000
                                                               <<06915>>57550000
WHILE LOOK < ITEMSCOUNT DO                                     <<06915>>57555000
BEGIN                                                          <<06915>>57560000
  IF NOT ( ITEMMIN <= ITEMS(LOOK) <= ITEMMAX ) THEN            <<06915>>57565000
    EXIT(BADITEM);                                             <<06915>>57570000
                                                               <<06915>>57575000
  CASE *ITEMS(LOOK) OF                                         <<06915>>57580000
  BEGIN                                                        <<06915>>57585000
    BEGIN END;                                                 <<06915>>57590000
    INFO(LOOK) := XDDS'SPOOL'STATE;                            <<06915>>57595000
    INFO(LOOK) := XDDS'DFID'NUMBER;                            <<06915>>57600000
    INFO(LOOK) := XDDS'OUTPUT'PRIORITY;                        <<06915>>57605000
    INFO(LOOK) := XDDS'NUMBER'EXTENTS;                         <<06915>>57610000
    INFO(LOOK) := XDDS'LAST'EXTENT'SIZE;                       <<06915>>57615000
    INFO(LOOK) := ODDS'NUMBER'COPIES;                          <<06915>>57620000
    INFO(LOOK) := XDDS'YEAR;                                   <<06915>>57625000
    INFO(LOOK) := XDDS'DAY'OF'YEAR;                            <<06915>>57630000
    INFO(LOOK) := XDDS'HOUR;                                   <<06915>>57635000
    INFO(LOOK) := XDDS'MINUTE;                                 <<06915>>57640000
    INFO(LOOK) := XDDS'DEVICE;                                 <<06915>>57645000
    INFO(LOOK) := XDDS'NEXT'SUBENTRY;                          <<06915>>57650000
  END;                                                         <<06915>>57655000
                                                               <<06915>>57660000
  LOOK := LOOK + 1;                                            <<06915>>57665000
END;                                                           <<06915>>57670000
                                                               <<06915>>57675000
<< 4.  >>                                                      <<06915>>57680000
LOOK := 0;                                                     <<06915>>57685000
                                                               <<06915>>57690000
WHILE LOOK < STRINGITEMSCOUNT DO                               <<06915>>57695000
BEGIN                                                          <<06915>>57700000
                                                               <<06915>>57705000
  IF NOT ( STRINGITEMMIN <= STRINGITEMS(LOOK) ) OR             <<06915>>57710000
     NOT ( STRINGITEMS(LOOK) <= STRINGITEMMAX ) THEN           <<06915>>57715000
    EXIT(BADSTRINGITEM);                                       <<06915>>57720000
                                                               <<06915>>57725000
  CASE *STRINGITEMS(LOOK) OF                                   <<06915>>57730000
  BEGIN                                                        <<06915>>57735000
    BEGIN END;                                                 <<06915>>57740000
    MOVE INFOSTRING(LOOK*BYTESPERSTRING) :=                    <<06915>>57745000
      XDDSB'FILE'NAME, (BYTESPERSTRING);                       <<06915>>57750000
    MOVE INFOSTRING(LOOK*BYTESPERSTRING) :=                    <<06915>>57755000
      XDDSB'USER'NAME, (BYTESPERSTRING);                       <<06915>>57760000
    MOVE INFOSTRING(LOOK*BYTESPERSTRING) :=                    <<06915>>57765000
      XDDSB'ACCOUNT'NAME, (BYTESPERSTRING);                    <<06915>>57770000
  END;                                                         <<06915>>57775000
                                                               <<06915>>57780000
  LOOK := LOOK + 1;                                            <<06915>>57785000
END;                                                           <<06915>>57790000
                                                               <<06915>>57795000
EXIT(OK);                                                      <<06915>>57800000
                                                               <<06915>>57805000
END; << PROCEDURE NRJESPOOLINFO >>                             <<06915>>57810000
$PAGE                                                          <<06915>>57815000
COMMENT:                                                       <<06915>>57820000
+-------------------------------------------------------+      <<06915>>57825000
|                         |                             |      <<06915>>57830000
| NRJESPOOLALTER          |                             |      <<06915>>57835000
|                         |                             |      <<06915>>57840000
| NRJESPOOLALTER changes  |  Algorithm                  |      <<06915>>57845000
| spool file characteris- |                             |      <<06915>>57850000
| tics (specified by types|  1. Return error if called  |      <<06915>>57855000
| in the items array), to |     in split stack mode,    |      <<06915>>57860000
| values passed in the    |     illegal itemscount val- |      <<06915>>57865000
| newvalues array.        |     ue, reference parameter |      <<06915>>57870000
|                         |     is out of bounds, ille- |      <<06915>>57875000
|                         |     gal queue value, or il- |      <<06915>>57880000
|                         |     legal index value. Use  |      <<06915>>57885000
| Input                   |     queue and index to find |      <<06915>>57890000
|                         |     spoolfile subentry @.   |      <<06915>>57895000
| QUEUE                   |                             |      <<06915>>57900000
|  odd header index which |  2. Get spoolfile subentry  |      <<06915>>57905000
|  specifies queue con-   |     from odd.               |      <<06915>>57910000
|  taining spool file     |                             |      <<06915>>57915000
| INDEX                   |  3. For each no. in items:  |      <<06915>>57920000
|  if first spool file in |                             |      <<06915>>57925000
|  queue, 1, else odd off-|     check if no. and associ-|      <<06915>>57930000
|  set of spool file sub- |     ated no. in newvalues ok|      <<06915>>57935000
|  entry                  |                             |      <<06915>>57940000
| ITEMS                   |     if altering state or    |      <<07333>>57945000
|  nos. representing spool|                             |      <<07333>>57950000
|  file characteristics to|                             |      <<07333>>57955000
|  be modified            |                             |      <<06915>>57960000
| ITEMSCOUNT              |     if altering priority,   |      <<07333>>57965000
|  no. of elements in     |                             |      <<07333>>57970000
|  items array            |                             |      <<07333>>57975000
| NEWVALUES               |                             |      <<06915>>57980000
|  nos. representing new  |     update spoolfile sub-   |      <<06915>>57985000
|  values of spool file   |     entry.                  |      <<06915>>57990000
|  characteristics speci- |                             |      <<06915>>57995000
|  fied in items array.   |  4. For each no. in string- |      <<06915>>58000000
|                         |     items:                  |      <<06915>>58005000
| Output                  |                             |      <<06915>>58010000
|                         |     check if no. is legal   |      <<06915>>58015000
| STATUS                  |                             |      <<06915>>58020000
|  no errors         -  0 |     update spoolfile sub-   |      <<06915>>58025000
|  parmoutbounds     - -10|     entry.                  |      <<06915>>58030000
|  badqueue          - -6 |                             |      <<06915>>58035000
|  badindex          - -2 |  5. Move altered subentry   |      <<06915>>58040000
|  badvalue          - -5 |     back to odd.  If spool  |      <<06915>>58045000
|  baditemscount     - -11|     file priority has been  |      <<06915>>58050000
|  baditem           - -9 |     changed, relink the     |      <<06915>>58055000
|  badstate          - -16|     odd according to new    |      <<06915>>58060000
|  nospoolfiles      - -14|     spool file priority     |      <<06915>>58065000
|  baddb             - -12|     (does no call SROOSTER).|      <<06915>>58070000
|  badstringitemscount- -4|                             |      <<06915>>58075000
|  badstringitem     - -1 |  BEFORE CALLING NRJESPOOL-  |      <<06915>>58080000
|                         |  ALTER, USER MUST OBTAIN THE|      <<06915>>58085000
|                         |  LDT AND ODD SIRS.          |      <<06915>>58090000
|                         |                             |      <<06915>>58095000
+-------------------------------------------------------+      <<06915>>58100000
END OF COMMENT;                                                <<06915>>58105000
                                                               <<06915>>58110000
PROCEDURE  NRJESPOOLALTER(  QUEUE,           << INPUT  >>      <<06915>>58115000
                            INDEX,           << INPUT  >>      <<06915>>58120000
                            ITEMS,           << INPUT  >>      <<06915>>58125000
                            ITEMSCOUNT,      << INPUT  >>      <<06915>>58130000
                            NEWVALUES,       << INPUT  >>      <<06915>>58135000
                            STRINGITEMS,     << INPUT  >>      <<06915>>58140000
                            STRINGITEMSCOUNT,<< INPUT  >>      <<06915>>58145000
                            STRINGNEWVALUES, << INPUT  >>      <<06915>>58150000
                            STATUS           << OUTPUT >>      <<06915>>58155000
                         );                                    <<06915>>58160000
                                                               <<06915>>58165000
<<-------------------- PARAMETERS --------------------->>      <<06915>>58170000
                                                               <<06915>>58175000
VALUE         QUEUE, INDEX, ITEMSCOUNT, STRINGITEMSCOUNT;      <<06915>>58180000
INTEGER       QUEUE, INDEX, ITEMSCOUNT, STRINGITEMSCOUNT;      <<06915>>58185000
INTEGER       STATUS;                                          <<06915>>58190000
INTEGER ARRAY ITEMS, NEWVALUES, STRINGITEMS;                   <<06915>>58195000
BYTE    ARRAY STRINGNEWVALUES;                                 <<06915>>58200000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>58205000
                                                               <<06915>>58210000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>58215000
                                                               <<06915>>58220000
BEGIN                                                          <<06915>>58225000
                                                               <<06915>>58230000
EQUATE  NUMPARMS     = 9,                                      <<06915>>58235000
        QMARKERLEN   = 4,                                      <<06915>>58240000
        MARKERNPARMS = NUMPARMS + QMARKERLEN;                  <<06915>>58245000
        << Maximum relative DB address of reference    >>      <<06915>>58250000
        << parameter is one word below location which  >>      <<06915>>58255000
        << contains address/value of 1st parameter.    >>      <<06915>>58260000
                                                               <<06915>>58265000
INTEGER XREG = X;                                              <<06915>>58270000
                                                               <<06915>>58275000
LOGICAL CRIT;                                                  <<06915>>58280000
                                                               <<06915>>58285000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>58290000
                                                               <<06915>>58295000
INTEGER ARRAY XDD(*) = DB + 0;                                 <<06915>>58300000
                                                               <<06915>>58305000
INTEGER POINTER XDD'HEAD;                                      <<06915>>58310000
                                                               <<06915>>58315000
INTEGER ARRAY XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY - 1);        <<06915>>58320000
BYTE    ARRAY XDD'BSUBENTRY(*) = XDD'SUBENTRY;                 <<06915>>58325000
                                                               <<06915>>58330000
INTEGER LOOK;                                                  <<06915>>58335000
                                                               <<06915>>58340000
LOGICAL PRIORITYCHANGE;                                        <<06915>>58345000
                                                               <<06915>>58350000
INTEGER QUEUEADDRESS, INDEXADDRESS;                            <<06915>>58355000
INTEGER POINTER RELINKADDRESS;                                 <<06915>>58360000
                                                               <<06915>>58365000
EQUATE  BYTESPERSTRING = 8,                                    <<06915>>58370000
        ROUNDUP        = BYTESPERWORD/2,                       <<06915>>58375000
        WORDSPERSTRING = (BYTESPERSTRING + ROUNDUP)/           <<06915>>58380000
                         BYTESPERWORD;                         <<06915>>58385000
                                                               <<06915>>58390000
EQUATE  NULLDEVICE = 0;                                        <<06915>>58395000
                                                               <<06915>>58400000
EQUATE  ITEMMIN           = 1,                                 <<06915>>58405000
        ITEMMAX           = 2,                                 <<06915>>58410000
        STRINGITEMMIN     = 1,                                 <<06915>>58415000
        STRINGITEMMAX     = 2,                                 <<06915>>58420000
        STATEMIN          = 0,                                 <<06915>>58425000
        STATEMAX          = 3,                                 <<06915>>58430000
        PRIORITYMIN       = 0,                                 <<06915>>58435000
        PRIORITYMAX       = 14;                                <<06915>>58440000
                                                               <<06915>>58445000
INTRINSIC QUIT, ARITRAP;                                       <<06915>>58450000
                                                               <<06915>>58455000
<<---------------------- EXIT ------------------------->>      <<06915>>58460000
<< Reset critical.  Record reason for return.  Return  >>      <<06915>>58465000
<< from procedure.                                     >>      <<06915>>58470000
<<----------------------------------------------------->>      <<06915>>58475000
SUBROUTINE EXIT( REASON );                                     <<06915>>58480000
VALUE REASON; INTEGER REASON;                                  <<06915>>58485000
BEGIN                                                          <<06915>>58490000
                                                               <<06915>>58495000
RESETCRITICAL(CRIT);                                           <<06915>>58500000
                                                               <<06915>>58505000
ARITRAP(TRUE);                                                 <<06915>>58510000
                                                               <<06915>>58515000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>58520000
   ( REASON = BADDB                              ) THEN        <<06915>>58525000
  QUIT(REASON);                                                <<06915>>58530000
                                                               <<06915>>58535000
STATUS := REASON;                                              <<06915>>58540000
                                                               <<06915>>58545000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>58550000
                                                               <<06915>>58555000
END;  << SUBROUTINE EXIT >>                                    <<06915>>58560000
                                                               <<06915>>58565000
<<-------------------- INITIAL ------------------------>>      <<06915>>58570000
<< Set critical.  Return error if called in split stack>>      <<06915>>58575000
<< mode, illegal itemscount value, reference parameter >>      <<06915>>58580000
<< out of bounds, illegal queue value, or illegal index>>      <<06915>>58585000
<< value.  Use queue and index values to calculate odd >>      <<06915>>58590000
<< offset of spool file subentry.                      >>      <<06915>>58595000
<<----------------------------------------------------->>      <<06915>>58600000
SUBROUTINE INITIAL;                                            <<06915>>58605000
BEGIN                                                          <<06915>>58610000
                                                               <<06915>>58615000
ARITRAP(FALSE);                                                <<06915>>58620000
                                                               <<06915>>58625000
CRIT := SETCRITICAL;                                           <<06915>>58630000
                                                               <<06915>>58635000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>58640000
                                                               <<06915>>58645000
IF ITEMSCOUNT < 0 THEN EXIT(BADITEMSCOUNT);                    <<06915>>58650000
IF STRINGITEMSCOUNT < 0 THEN EXIT(BADSTRINGITEMSCOUNT);        <<06915>>58655000
IF ( NOT FBNDCHK( @STATUS,             1, @QMINUSPARMS ) ) OR  <<06915>>58660000
   ( NOT FBNDCHK( @ITEMS,     ITEMSCOUNT, @QMINUSPARMS ) ) OR  <<06915>>58665000
   ( NOT FBNDCHK( @NEWVALUES, ITEMSCOUNT, @QMINUSPARMS ) ) OR  <<06915>>58670000
   ( NOT FBNDCHK( @STRINGITEMS,                                <<06915>>58675000
                  STRINGITEMSCOUNT,                            <<06915>>58680000
                  @QMINUSPARMS                         ) ) OR  <<06915>>58685000
   ( NOT FBNDCHK( WORDADDRESS(STRINGNEWVALUES),                <<06915>>58690000
                  STRINGITEMSCOUNT * WORDSPERSTRING,           <<06915>>58695000
                  @QMINUSPARMS                         ) ) THEN<<06915>>58700000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>58705000
                                                               <<06915>>58710000
IF QUEUE = CLASSQUEUE THEN QUEUEADDRESS:=XDD'CLASS'ENTRY       <<06915>>58715000
ELSE QUEUEADDRESS := QUEUE * SIZE'OF'XDD'HEAD;                 <<06915>>58720000
                                                               <<06915>>58725000
EXCHANGEDB(ODD'DST);                                           <<06915>>58730000
                                                               <<06915>>58735000
IF NOT ( XDD'CLASS'ENTRY <= QUEUEADDRESS          ) OR         <<06915>>58740000
   NOT ( QUEUEADDRESS <= XDD0'SUBENTRY'AREA -                  <<06915>>58745000
                         SIZE'OF'XDD'HEAD         ) THEN       <<06915>>58750000
BEGIN                                                          <<06915>>58755000
  EXCHANGEDB(0);                                               <<06915>>58760000
  EXIT(BADQUEUE);                                              <<06915>>58765000
END;                                                           <<06915>>58770000
                                                               <<06915>>58775000
@XDD'HEAD := QUEUEADDRESS;                                     <<06915>>58780000
                                                               <<06915>>58785000
IF INDEX = FIRSTINQUEUE                                        <<06915>>58790000
THEN INDEXADDRESS := XDDH'FIRST'SUBENTRY                       <<06915>>58795000
ELSE INDEXADDRESS := INDEX;                                    <<06915>>58800000
                                                               <<06915>>58805000
IF INDEXADDRESS = NILL'LINK THEN                               <<06915>>58810000
BEGIN                                                          <<06915>>58815000
  EXCHANGEDB(0);                                               <<06915>>58820000
  EXIT(NOSPOOLFILES);                                          <<06915>>58825000
END;                                                           <<06915>>58830000
                                                               <<06915>>58835000
IF NOT ( XDD0'SUBENTRY'AREA <= INDEXADDRESS     ) OR           <<06915>>58840000
   NOT ( INDEXADDRESS <= XDD0'CURRENT'SECTORS *                <<06915>>58845000
                         WORDSPERSECTOR       -                <<06915>>58850000
                         SIZE'OF'XDD'SUBENTRY   ) THEN         <<06915>>58855000
BEGIN                                                          <<06915>>58860000
  EXCHANGEDB(0);                                               <<06915>>58865000
  EXIT(BADINDEX);                                              <<06915>>58870000
END;                                                           <<06915>>58875000
                                                               <<06915>>58880000
EXCHANGEDB(0);                                                 <<06915>>58885000
                                                               <<06915>>58890000
END; << SUBROUTINE INITIAL >>                                  <<06915>>58895000
                                                               <<06915>>58900000
<<-------------------- GETSUBENTRY -------------------->>      <<06915>>58905000
<< Move spool file subentry from odd to procedure's    >>      <<06915>>58910000
<< stack.  Check that subentry corresponds to queue    >>      <<06915>>58915000
<< passed by user.                                     >>      <<06915>>58920000
<<----------------------------------------------------->>      <<06915>>58925000
SUBROUTINE GETSUBENTRY;                                        <<06915>>58930000
BEGIN                                                          <<06915>>58935000
                                                               <<06915>>58940000
TOS := @XDD'SUBENTRY;                                          <<06915>>58945000
TOS := ODD'DST;                                                <<06915>>58950000
TOS := INDEXADDRESS;                                           <<06915>>58955000
TOS := SIZE'OF'XDD'SUBENTRY;                                   <<06915>>58960000
ASSEMBLE( MFDS 4 );                                            <<06915>>58965000
                                                               <<06915>>58970000
IF ( QUEUE <> XDDS'HEAD'INDEX           ) OR                   <<06915>>58975000
   ( XDDS'SPOOFLE'VT'INDEX = NULLDEVICE ) THEN                 <<06915>>58980000
  EXIT(BADINDEX);                                              <<06915>>58985000
                                                               <<06915>>58990000
END; << SUBROUTINE GETSUBENTRY >>                              <<06915>>58995000
                                                               <<06915>>59000000
<<----------------- PUTSUBENTRY ----------------------->>      <<06915>>59005000
<< Move altered spool file subentry from procedure's   >>      <<06915>>59010000
<< stack to the odd.                                   >>      <<06915>>59015000
<<----------------------------------------------------->>      <<06915>>59020000
                                                               <<06915>>59025000
SUBROUTINE PUTSUBENTRY;                                        <<06915>>59030000
BEGIN                                                          <<06915>>59035000
                                                               <<06915>>59040000
TOS := ODD'DST;                                                <<06915>>59045000
TOS := INDEXADDRESS;                                           <<06915>>59050000
TOS := @XDD'SUBENTRY;                                          <<06915>>59055000
TOS := SIZE'OF'XDD'SUBENTRY;                                   <<06915>>59060000
ASSEMBLE( MTDS 4 );                                            <<06915>>59065000
                                                               <<06915>>59070000
IF PRIORITYCHANGE THEN                                         <<06915>>59075000
BEGIN                                                          <<06915>>59080000
  @RELINKADDRESS  := INDEXADDRESS;                             <<06915>>59085000
  SRELINKODD( RELINKADDRESS,                                   <<06915>>59090000
              IF LOGICAL(XDDS'CLASS) THEN -XDDS'DEVICE         <<06915>>59095000
              ELSE XDDS'DEVICE                         );      <<06915>>59100000
END;                                                           <<06915>>59105000
                                                               <<06915>>59110000
END; << SUBROUTINE PUTSUBENTRY >>                              <<06915>>59115000
                                                               <<06915>>59120000
<<----------------- MOVESPOOLSTATE -------------------->>      <<06915>>59125000
<< Check for illegal new spool state value and update  >>      <<07333>>59130000
<< subentry spool file state.                          >>      <<07333>>59135000
<<----------------------------------------------------->>      <<06915>>59140000
SUBROUTINE MOVESPOOLSTATE;                                     <<06915>>59145000
BEGIN                                                          <<06915>>59150000
                                                               <<06915>>59155000
IF NOT ( STATEMIN <= NEWVALUES(LOOK) <= STATEMAX ) THEN        <<06915>>59160000
  EXIT(BADVALUE);                                              <<06915>>59165000
                                                               <<06915>>59170000
XDDS'SPOOL'STATE := NEWVALUES(LOOK);                           <<06915>>59175000
                                                               <<06915>>59180000
END; << SUBROUTINE MOVESPOOLSTATE >>                           <<06915>>59185000
                                                               <<06915>>59190000
<<--------------- MOVESPOOLPRIORITY ------------------->>      <<06915>>59195000
<< Check for illegal new priority, update spool file   >>      <<07333>>59200000
<< subentry priority, and set flag so that queue will  >>      <<07333>>59205000
<< be relinked according to new spool file priority.   >>      <<07333>>59210000
<<----------------------------------------------------->>      <<06915>>59215000
SUBROUTINE MOVESPOOLPRIORITY;                                  <<06915>>59220000
BEGIN                                                          <<06915>>59225000
                                                               <<06915>>59230000
IF NOT ( PRIORITYMIN <= NEWVALUES(LOOK) <= PRIORITYMAX )       <<06915>>59235000
  THEN EXIT(BADVALUE);                                         <<06915>>59240000
                                                               <<06915>>59245000
                                                               <<06915>>59250000
XDDS'OUTPUT'PRIORITY := NEWVALUES(LOOK);                       <<06915>>59255000
                                                               <<06915>>59260000
PRIORITYCHANGE := TRUE;                                        <<06915>>59265000
                                                               <<06915>>59270000
                                                               <<06915>>59275000
END; << SUBROUTINE MOVESPOOLPRIORITY >>                        <<06915>>59280000
                                                               <<06915>>59285000
<<----------------- NRJESPOOLALTER -------------------->>      <<06915>>59290000
                                                               <<06915>>59295000
                                                               <<06915>>59300000
<< 1. >>                                                       <<06915>>59305000
INITIAL;                                                       <<06915>>59310000
                                                               <<06915>>59315000
<< 2. >>                                                       <<06915>>59320000
GETSUBENTRY;                                                   <<06915>>59325000
                                                               <<06915>>59330000
<< 3. >>                                                       <<06915>>59335000
LOOK := 0; PRIORITYCHANGE := FALSE;                            <<06915>>59340000
                                                               <<06915>>59345000
WHILE LOOK < ITEMSCOUNT DO                                     <<06915>>59350000
BEGIN                                                          <<06915>>59355000
  IF NOT ( ITEMMIN <= ITEMS(LOOK) <= ITEMMAX ) THEN            <<06915>>59360000
    EXIT(BADITEM);                                             <<06915>>59365000
                                                               <<06915>>59370000
  CASE *ITEMS(LOOK) OF                                         <<06915>>59375000
  BEGIN                                                        <<06915>>59380000
    BEGIN END;                                                 <<06915>>59385000
    MOVESPOOLSTATE;                                            <<06915>>59390000
    MOVESPOOLPRIORITY;                                         <<06915>>59395000
  END;                                                         <<06915>>59400000
                                                               <<06915>>59405000
  LOOK := LOOK + 1;                                            <<06915>>59410000
END;                                                           <<06915>>59415000
                                                               <<06915>>59420000
<< 4. >>                                                       <<06915>>59425000
LOOK := 0;                                                     <<06915>>59430000
                                                               <<06915>>59435000
WHILE LOOK < STRINGITEMSCOUNT DO                               <<06915>>59440000
BEGIN                                                          <<06915>>59445000
                                                               <<06915>>59450000
  IF NOT ( STRINGITEMMIN <= STRINGITEMS(LOOK) ) OR             <<06915>>59455000
     NOT ( STRINGITEMS(LOOK) <= STRINGITEMMAX ) THEN           <<06915>>59460000
    EXIT(BADSTRINGITEM);                                       <<06915>>59465000
                                                               <<06915>>59470000
  CASE *STRINGITEMS(LOOK) OF                                   <<06915>>59475000
  BEGIN                                                        <<06915>>59480000
    BEGIN END;                                                 <<06915>>59485000
    MOVE XDDSB'FILE'NAME :=                                    <<06915>>59490000
      STRINGNEWVALUES(LOOK*BYTESPERSTRING),                    <<06915>>59495000
      (BYTESPERSTRING);                                        <<06915>>59500000
    MOVE XDDSB'JOB'NAME  :=                                    <<06915>>59505000
      STRINGNEWVALUES(LOOK*BYTESPERSTRING),                    <<06915>>59510000
      (BYTESPERSTRING);                                        <<06915>>59515000
  END;                                                         <<06915>>59520000
                                                               <<06915>>59525000
  LOOK := LOOK + 1;                                            <<06915>>59530000
END;                                                           <<06915>>59535000
                                                               <<06915>>59540000
<< 5. >>                                                       <<06915>>59545000
PUTSUBENTRY;                                                   <<06915>>59550000
                                                               <<06915>>59555000
EXIT(OK);                                                      <<06915>>59560000
                                                               <<06915>>59565000
END; << PROCEDURE NRJESPOOLALTER >>                            <<06915>>59570000
$PAGE                                                          <<06915>>59575000
COMMENT:                                                       <<06915>>59580000
+-------------------------------------------------------+      <<06915>>59585000
|                         |                             |      <<06915>>59590000
| NRJESPOOLOPEN           |  Algorithm                  |      <<06915>>59595000
|                         |                             |      <<06915>>59600000
| NRJESPOOLOPEN performs  |  1. Return error if called  |      <<06915>>59605000
| an fsopen on the spool  |     in split stack mode,    |      <<06915>>59610000
| file specified by the   |     reference parameter out |      <<06915>>59615000
| queue and index param-  |     of bounds, illegal index|      <<06915>>59620000
| eters.  Also, the pro-  |     value, illegal queue    |      <<06915>>59625000
| cedure returns compres- |     value, or spool file not|      <<06915>>59630000
| sion, compaction, and   |     locked.  Use queue and  |      <<06915>>59635000
| translation information |     index values to find    |      <<06915>>59640000
| stored in the spool     |     odd offset of spool file|      <<06915>>59645000
| file.                   |     subentry.  Initialize   |      <<06915>>59650000
|                         |     functional return.      |      <<06915>>59655000
| Input                   |                             |      <<06915>>59660000
|                         |  2. Call fsopen to open     |      <<06915>>59665000
| QUEUE                   |     spool file.             |      <<06915>>59670000
|  odd head index of queue|                             |      <<06915>>59675000
|  which contains spool   |  3. Read first block of     |      <<06915>>59680000
|  file                   |     spool file.  Initialize |      <<06915>>59685000
|                         |     record index to 1st rec.|      <<06915>>59690000
|                         |                             |      <<06915>>59695000
|                         |  4. If 1st record is fopen  |      <<06915>>59700000
| INDEX                   |     record, increment record|      <<06915>>59705000
|  if first spool file in |     index. Check if record  |      <<06915>>59710000
|  queue, 1, else ODD off-|     is NRJE fdevicecontrol  |      <<06915>>59715000
|  set of spool file sub- |     record. If NRJE fdevice-|      <<06915>>59720000
|  entry                  |     control record present, |      <<06915>>59725000
| COMMAREA                |     record NRJE compression,|      <<06915>>59730000
|  a 515 word array in    |     compaction, and transla-|      <<06915>>59735000
|  which NRJESPOOLOPEN/RE-|     tion information.  Ini- |      <<06915>>59740000
|  WIND/READ store a spool|     tialize index to next   |      <<06915>>59745000
|  file block             |     record.  Also, initial- |      <<06915>>59750000
| FOPTIONS                |     ize block count to first|      <<06915>>59755000
|  foptions to be passed  |     block.                  |      <<06915>>59760000
|  to fsopen              |                             |      <<06915>>59765000
| AOPTIONS                |                             |      <<06915>>59770000
|  aoptions to be passed  |                             |      <<06915>>59775000
|  to fsopen              |                             |      <<06915>>59780000
|                         |     Output Continued        |      <<06915>>59785000
|  Output                 |                             |      <<06915>>59790000
|                         |                             |      <<06915>>59795000
| COMPRESSION             |     TRANSLATION             |      <<06915>>59800000
|  if data in spool file  |      contains CTRANSLATE    |      <<06915>>59805000
|  compressed, 1, else 0  |      code indicating charac-|      <<06915>>59810000
| COMPACTION              |      ter set of spool file  |      <<06915>>59815000
|  if data in spool file  |      data.                  |      <<06915>>59820000
|  compacted, 1, else 0   |     STATUS                  |      <<06915>>59825000
| FUNCTIONAL RETURN       |      no errors         - 0  |      <<06915>>59830000
|  file system id no. of  |      parmoutbounds     - -10|      <<06915>>59835000
|  opened spool file.     |      baddb             - -12|      <<06915>>59840000
|                         |      nospoolfiles      - -14|      <<06915>>59845000
|                         |      badstate          - -16|      <<06915>>59850000
|                         |      endofspoolfile    - -13|      <<06915>>59855000
|                         |      badqueue          - -6 |      <<06915>>59860000
|                         |      badindex          - -2 |      <<06915>>59865000
|                         |      file system errors     |      <<06915>>59870000
|                         |                             |      <<06915>>59875000
+-------------------------------------------------------+      <<06915>>59880000
END OF COMMENT;                                                <<06915>>59885000
                                                               <<06915>>59890000
INTEGER                                                        <<06915>>59895000
PROCEDURE NRJESPOOLOPEN(  QUEUE,          << INPUT  >>         <<06915>>59900000
                          INDEX,          << INPUT  >>         <<06915>>59905000
                          COMMAREA,       << INPUT  >>         <<06915>>59910000
                          FOPTIONS,       << INPUT  >>         <<06915>>59915000
                          AOPTIONS,       << INPUT  >>         <<06915>>59920000
                          COMPRESSION,    << OUTPUT >>         <<06915>>59925000
                          COMPACTION,     << OUTPUT >>         <<06915>>59930000
                          TRANSLATION,    << OUTPUT >>         <<06915>>59935000
                          STATUS          << OUTPUT >>         <<06915>>59940000
                       );                                      <<06915>>59945000
                                                               <<06915>>59950000
<<-------------------- PARAMETERS --------------------->>      <<06915>>59955000
                                                               <<06915>>59960000
VALUE         QUEUE, INDEX, FOPTIONS, AOPTIONS;                <<06915>>59965000
INTEGER       QUEUE, INDEX, FOPTIONS, AOPTIONS,                <<06915>>59970000
              COMPRESSION, COMPACTION, TRANSLATION,            <<06915>>59975000
              STATUS;                                          <<06915>>59980000
LOGICAL ARRAY COMMAREA;                                        <<06915>>59985000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>59990000
                                                               <<06915>>59995000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>60000000
                                                               <<06915>>60005000
BEGIN                                                          <<06915>>60010000
                                                               <<06915>>60015000
EQUATE  NUMPARMS     = 9,                                      <<06915>>60020000
        QMARKERLEN   = 4,                                      <<06915>>60025000
        MARKERNPARMS = NUMPARMS + QMARKERLEN + 1;              <<06915>>60030000
        << Maximum DB relative address of reference    >>      <<06915>>60035000
        << parameter is one word below location which  >>      <<06915>>60040000
        << contains functional return.                 >>      <<06915>>60045000
                                                               <<06915>>60050000
                                                               <<06915>>60055000
INTEGER XREG = X;                                              <<06915>>60060000
                                                               <<06915>>60065000
LOGICAL CRIT;                                                  <<06915>>60070000
                                                               <<06915>>60075000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>60080000
                                                               <<06915>>60085000
INTEGER ARRAY XDD(*) = DB + 0;                                 <<06915>>60090000
                                                               <<06915>>60095000
INTEGER ARRAY ICOMMAREA(*) = COMMAREA;                         <<06915>>60100000
DOUBLE ARRAY  DCOMMAREA(*) = COMMAREA;                         <<06915>>60105000
                                                               <<06915>>60110000
DOUBLE FIRSTBLOCK := 0D;                                       <<06915>>60115000
                                                               <<06915>>60120000
INTEGER POINTER XDD'HEAD, XDD'SUBENTRY;                        <<06915>>60125000
                                                               <<06915>>60130000
INTEGER ERRORCODE, FNUM;                                       <<06915>>60135000
                                                               <<06915>>60140000
INTEGER QUEUEADDRESS, INDEXADDRESS;                            <<06915>>60145000
                                                               <<06915>>60150000
EQUATE  NRJEFUNCTIONCODE  = 193,                               <<06915>>60155000
        FOPENFUNCTIONCODE = 3;                                 <<06915>>60160000
                                                               <<06915>>60165000
EQUATE  FIRSTRECORDINBLOCK = 0;                                <<06915>>60170000
                                                               <<06915>>60175000
EQUATE  FSOPENMASK         = %100000;                          <<06915>>60180000
                                                               <<06915>>60185000
EQUATE NULLDEVICE = 0;                                         <<06915>>60190000
                                                               <<06915>>60195000
EQUATE  NULL = 0;                                              <<06915>>60200000
                                                               <<06915>>60205000
INTRINSIC FREADDIR, FCHECK, ARITRAP, QUIT;                     <<06915>>60210000
                                                               <<06915>>60215000
<<---------------------- EXIT ------------------------->>      <<06915>>60220000
<< Reset critical.  Record reason for return.  Return  >>      <<06915>>60225000
<< from procedure.                                     >>      <<06915>>60230000
<<----------------------------------------------------->>      <<06915>>60235000
SUBROUTINE EXIT( REASON );                                     <<06915>>60240000
VALUE REASON; INTEGER REASON;                                  <<06915>>60245000
BEGIN                                                          <<06915>>60250000
                                                               <<06915>>60255000
                                                               <<06915>>60260000
RESETCRITICAL(CRIT);                                           <<06915>>60265000
                                                               <<06915>>60270000
ARITRAP(TRUE);                                                 <<06915>>60275000
                                                               <<06915>>60280000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>60285000
   ( REASON = BADDB                              ) THEN        <<06915>>60290000
  QUIT(REASON);                                                <<06915>>60295000
                                                               <<06915>>60300000
STATUS := REASON;                                              <<06915>>60305000
                                                               <<06915>>60310000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>60315000
                                                               <<06915>>60320000
END; << SUBROUTINE EXIT >>                                     <<06915>>60325000
                                                               <<06915>>60330000
<<-------------------- INITIAL ------------------------>>      <<06915>>60335000
<< Set critical.  Return error if called in splitstack,>>      <<06915>>60340000
<< reference parameter out of bounds, illegal queue    >>      <<06915>>60345000
<< value, illegal index value, or spool file not lock- >>      <<06915>>60350000
<< ed.  Use queue and index values to find odd offset  >>      <<06915>>60355000
<< of spool file subentry.  Initialize functional re-  >>      <<06915>>60360000
<< turn.                                               >>      <<06915>>60365000
<<----------------------------------------------------->>      <<06915>>60370000
SUBROUTINE INITIAL;                                            <<06915>>60375000
BEGIN                                                          <<06915>>60380000
                                                               <<06915>>60385000
ARITRAP(FALSE);                                                <<06915>>60390000
                                                               <<06915>>60395000
CRIT := SETCRITICAL;                                           <<06915>>60400000
                                                               <<06915>>60405000
NRJESPOOLOPEN := 0;                                            <<06915>>60410000
                                                               <<06915>>60415000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>60420000
                                                               <<06915>>60425000
IF ( NOT FBNDCHK( @STATUS,             1, @QMINUSPARMS ) ) OR  <<06915>>60430000
   ( NOT FBNDCHK( @COMPRESSION,        1, @QMINUSPARMS ) ) OR  <<06915>>60435000
   ( NOT FBNDCHK( @COMPACTION,         1, @QMINUSPARMS ) ) OR  <<06915>>60440000
   ( NOT FBNDCHK( @TRANSLATION,        1, @QMINUSPARMS ) ) OR  <<06915>>60445000
   ( NOT FBNDCHK( @COMMAREA,                                   <<06915>>60450000
                  SIZE'OF'COMMAREA,                            <<06915>>60455000
                  @QMINUSPARMS                         ) ) THEN<<06915>>60460000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>60465000
                                                               <<06915>>60470000
EXCHANGEDB(ODD'DST);                                           <<06915>>60475000
                                                               <<06915>>60480000
IF QUEUE = CLASSQUEUE THEN QUEUEADDRESS:=XDD'CLASS'ENTRY       <<06915>>60485000
ELSE QUEUEADDRESS := QUEUE * SIZE'OF'XDD'HEAD;                 <<06915>>60490000
                                                               <<06915>>60495000
IF NOT ( XDD'CLASS'ENTRY <= QUEUEADDRESS         ) OR          <<06915>>60500000
   NOT (QUEUEADDRESS <= XDD0'SUBENTRY'AREA -                   <<06915>>60505000
                        SIZE'OF'XDD'HEAD         ) THEN        <<06915>>60510000
BEGIN                                                          <<06915>>60515000
  EXCHANGEDB(0);                                               <<06915>>60520000
  EXIT(BADQUEUE);                                              <<06915>>60525000
END;                                                           <<06915>>60530000
                                                               <<06915>>60535000
@XDD'HEAD := QUEUEADDRESS;                                     <<06915>>60540000
                                                               <<06915>>60545000
IF INDEX = FIRSTINQUEUE THEN                                   <<06915>>60550000
INDEXADDRESS := XDDH'FIRST'SUBENTRY                            <<06915>>60555000
ELSE INDEXADDRESS := INDEX;                                    <<06915>>60560000
                                                               <<06915>>60565000
IF INDEXADDRESS = NILL'LINK THEN                               <<06915>>60570000
BEGIN                                                          <<06915>>60575000
  EXCHANGEDB(0);                                               <<06915>>60580000
  EXIT(NOSPOOLFILES);                                          <<06915>>60585000
END;                                                           <<06915>>60590000
                                                               <<06915>>60595000
IF NOT ( XDD0'SUBENTRY'AREA <= INDEXADDRESS      ) OR          <<06915>>60600000
   NOT ( INDEXADDRESS <= XDD0'CURRENT'SECTORS *                <<06915>>60605000
                         WORDSPERSECTOR       -                <<06915>>60610000
                         SIZE'OF'XDD'SUBENTRY    ) THEN        <<06915>>60615000
BEGIN                                                          <<06915>>60620000
  EXCHANGEDB(0);                                               <<06915>>60625000
  EXIT(BADINDEX);                                              <<06915>>60630000
END;                                                           <<06915>>60635000
                                                               <<06915>>60640000
@XDD'SUBENTRY := INDEXADDRESS;                                 <<06915>>60645000
                                                               <<06915>>60650000
IF ( QUEUE <> XDDS'HEAD'INDEX           ) OR                   <<06915>>60655000
   ( XDDS'SPOOFLE'VT'INDEX = NULLDEVICE ) THEN                 <<06915>>60660000
BEGIN                                                          <<06915>>60665000
  EXCHANGEDB(0);                                               <<06915>>60670000
  EXIT(BADINDEX);                                              <<06915>>60675000
END;                                                           <<06915>>60680000
                                                               <<06915>>60685000
IF XDDS'SPOOL'STATE <> XDDS'LOCKED THEN                        <<06915>>60690000
BEGIN                                                          <<06915>>60695000
 EXCHANGEDB(0);                                                <<06915>>60700000
 EXIT(BADSTATE);                                               <<06915>>60705000
END;                                                           <<06915>>60710000
                                                               <<06915>>60715000
EXCHANGEDB(0);                                                 <<06915>>60720000
                                                               <<06915>>60725000
END; << SUBROUTINE INITIAL >>                                  <<06915>>60730000
                                                               <<06915>>60735000
<<----------------- NRJESPOOLOPEN --------------------->>      <<06915>>60740000
                                                               <<06915>>60745000
                                                               <<06915>>60750000
<< 1. >>                                                       <<06915>>60755000
INITIAL;                                                       <<06915>>60760000
                                                               <<06915>>60765000
                                                               <<06915>>60770000
<< 2. >>                                                       <<06915>>60775000
INDEXADDRESS := LOGICAL(INDEXADDRESS) LOR FSOPENMASK;          <<06915>>60780000
                                                               <<06915>>60785000
FNUM := FSOPEN( , FOPTIONS, AOPTIONS, INDEXADDRESS );          <<06915>>60790000
IF <> THEN                                                     <<06915>>60795000
BEGIN                                                          <<06915>>60800000
  FCHECK( FNUM, ERRORCODE );                                   <<06915>>60805000
  IF ERRORCODE = 0 THEN EXIT(ENDOFSPOOLFILE)                   <<06915>>60810000
  ELSE EXIT(ERRORCODE);                                        <<06915>>60815000
END;                                                           <<06915>>60820000
                                                               <<06915>>60825000
NRJESPOOLOPEN := FNUM;                                         <<06915>>60830000
                                                               <<06915>>60835000
SPBLOCK'BLOCKNUM := FIRSTBLOCK;                                <<06915>>60840000
                                                               <<06915>>60845000
<< 3. >>                                                       <<06915>>60850000
FREADDIR( FNUM, COMMAREA, SIZE'OF'SPBLOCK, SPBLOCK'BLOCKNUM ); <<06915>>60855000
IF <> THEN                                                     <<06915>>60860000
BEGIN                                                          <<06915>>60865000
  FCHECK( FNUM, ERRORCODE );                                   <<06915>>60870000
  EXIT(ERRORCODE);                                             <<06915>>60875000
END;                                                           <<06915>>60880000
SPBLOCK'RECORDPOINTER := FIRSTRECORDINBLOCK;                   <<06915>>60885000
                                                               <<06915>>60890000
<< 4. >>                                                       <<06915>>60895000
IF SPRECORD'FUNCTIONCODE = FOPENFUNCTIONCODE THEN              <<06915>>60900000
  SPBLOCK'RECORDPOINTER := FIRSTRECORDINBLOCK +                <<06915>>60905000
                           (SPRECORD'COUNT + ROUNDUP) /        <<06915>>60910000
                           BYTESPERWORD;                       <<06915>>60915000
                                                               <<06915>>60920000
IF SPRECORD'FUNCTIONCODE = NRJEFUNCTIONCODE AND                <<07174>>60925000
   SPRECORD'TRUNCDATACOUNT = 0              THEN               <<07174>>60930000
BEGIN                                                          <<06915>>60935000
  TRANSLATION := SPRECORD'TRANSLATION;                         <<06915>>60940000
  COMPRESSION := SPRECORD'COMPRESSION;                         <<06915>>60945000
  COMPACTION  := SPRECORD'COMPACTION;                          <<06915>>60950000
  SPBLOCK'RECORDPOINTER := SPBLOCK'RECORDPOINTER +             <<06915>>60955000
    (SPRECORD'COUNT + ROUNDUP) / BYTESPERWORD;                 <<06915>>60960000
END                                                            <<06915>>60965000
ELSE                                                           <<06915>>60970000
BEGIN                                                          <<06915>>60975000
  TRANSLATION := NULL;                                         <<06915>>60980000
  COMPRESSION := NULL;                                         <<06915>>60985000
  COMPACTION  := NULL;                                         <<06915>>60990000
END;                                                           <<06915>>60995000
                                                               <<06915>>61000000
EXIT(OK);                                                      <<06915>>61005000
                                                               <<06915>>61010000
END; << PROCEDURE NRJESPOOLOPEN >>                             <<06915>>61015000
$PAGE                                                          <<06915>>61020000
COMMENT:                                                       <<06915>>61025000
+-------------------------------------------------------+      <<06915>>61030000
|                         |                             |      <<06915>>61035000
| NRJESPOOLREAD           |   Algorithm                 |      <<06915>>61040000
|                         |                             |      <<06915>>61045000
| NRJESPOOLREAD performs  |  1. Return error if called  |      <<06915>>61050000
| sequential reads to an  |     in split stack mode or  |      <<06915>>61055000
| opened spool file by    |     reference parameter out |      <<06915>>61060000
| executing the fread in- |     of bounds.  Initialize  |      <<06915>>61065000
| trinsic.  NRJESPOOLREAD |     trunccount and expan-   |      <<06915>>61070000
| returns a record, not   |     count.  Change incount  |      <<06915>>61075000
| a block.                |     to positive byte count. |      <<06915>>61080000
|                         |                             |      <<06915>>61085000
| Input                   |  2. Scan for next data re-  |      <<06915>>61090000
|                         |     cord, skipping over non-|      <<06915>>61095000
| FNUM                    |     fwrite records, updating|      <<06915>>61100000
|  file system number     |     the record index, read- |      <<06915>>61105000
|  which identifies an    |     ing consecutive spool   |      <<06915>>61110000
|  opened spool file      |     file blocks, and updat- |      <<06915>>61115000
| COMMAREA                |     ing the block count,    |      <<06915>>61120000
|  an area used by NRJE-  |     until find data record  |      <<06915>>61125000
|  SPOOLREAD for global   |     or reach the end of     |      <<06915>>61130000
|  storage (storing spool |     spool file.             |      <<06915>>61135000
|  file block)            |                             |      <<06915>>61140000
| INCOUNT                 |     If find end of spool    |      <<06915>>61145000
|  if negative integer,   |     file, return error code.|      <<06915>>61150000
|  number of bytes of re- |                             |      <<06915>>61155000
|  cord to be transferred,|     If find data record, re-|      <<06915>>61160000
|  else if positive inte- |     turn data record and    |      <<06915>>61165000
|  ger, number of words of|     increment record index  |      <<06915>>61170000
|  record to be transfer- |     to the next record.     |      <<06915>>61175000
|  red                    |                             |      <<06915>>61180000
|                         |                             |      <<06915>>61185000
|  Output                 |   Output Continued          |      <<06915>>61190000
|                         |                             |      <<06915>>61195000
|                         |                             |      <<06915>>61200000
| TRUNCCOUNT              |   RECID                     |      <<06915>>61205000
|  positive no. repre-    |    a three word identifier  |      <<06915>>61210000
|  senting no. of bytes   |    associated with the data |      <<06915>>61215000
|  (incount was negative) |    record in buffer--used   |      <<06915>>61220000
|  or no. of words (in-   |    by NRJESPOOLREWIND       |      <<06915>>61225000
|  count was positive) of |   BUFFER                    |      <<06915>>61230000
|  data transferred       |    contains spool file re-  |      <<06915>>61235000
| EXPANCOUNT              |    cord                     |      <<06915>>61240000
|  positive no. repre-    |   STATUS                    |      <<06915>>61245000
|  senting no. of bytes   |    no errors      -  0      |      <<06915>>61250000
|  (incount was negative) |    parmoutbounds  -  -10    |      <<06915>>61255000
|  or no. of words (in-   |    endofspoolfile -  -13    |      <<06915>>61260000
|  count was positive) of |    baddb          -  -12    |      <<06915>>61265000
|  data in record, includ-|    file system errors       |      <<06915>>61270000
|  ing any trailing blanks|   RECTYPE                   |      <<07064>>61275000
|                         |    0=fwrite rec., 1=NRJE    |      <<07064>>61280000
|                         |      fdevicecontrol rec.    |      <<07064>>61285000
+-------------------------------------------------------+      <<06915>>61290000
END OF COMMENT;                                                <<06915>>61295000
                                                               <<06915>>61300000
PROCEDURE NRJESPOOLREAD(  FNUM,           << INPUT  >>         <<06915>>61305000
                          COMMAREA,       << INPUT  >>         <<06915>>61310000
                          INCOUNT,        << INPUT  >>         <<06915>>61315000
                          TRUNCCOUNT,     << OUTPUT >>         <<06915>>61320000
                          EXPANCOUNT,     << OUTPUT >>         <<06915>>61325000
                          RECTYPE,        << OUTPUT >>         <<07064>>61330000
                          RECID,          << OUTPUT >>         <<06915>>61335000
                          BUFFER,         << OUTPUT >>         <<06915>>61340000
                          STATUS          << OUTPUT >>         <<06915>>61345000
                       );                                      <<06915>>61350000
                                                               <<06915>>61355000
<<-------------------- PARAMETERS --------------------->>      <<06915>>61360000
                                                               <<06915>>61365000
VALUE         FNUM, INCOUNT;                                   <<06915>>61370000
INTEGER       FNUM, INCOUNT, TRUNCCOUNT, EXPANCOUNT;           <<06915>>61375000
INTEGER       STATUS, RECTYPE;                                 <<07064>>61380000
INTEGER ARRAY RECID;                                           <<06915>>61385000
ARRAY         COMMAREA, BUFFER;                                <<06915>>61390000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>61395000
                                                               <<06915>>61400000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>61405000
                                                               <<06915>>61410000
BEGIN                                                          <<06915>>61415000
                                                               <<06915>>61420000
EQUATE  NUMPARMS    = 9,                                       <<07064>>61425000
        QMARKERLEN  = 4,                                       <<06915>>61430000
        MARKERNPARMS= NUMPARMS + QMARKERLEN;                   <<06915>>61435000
        << Maximum DB relative address of a reference  >>      <<06915>>61440000
        << parameter is one word below the location    >>      <<06915>>61445000
        << which contains address/value of 1st parm.   >>      <<06915>>61450000
                                                               <<06915>>61455000
INTEGER XREG = X;                                              <<06915>>61460000
                                                               <<06915>>61465000
LOGICAL CRIT;                                                  <<06915>>61470000
                                                               <<06915>>61475000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>61480000
                                                               <<06915>>61485000
INTEGER ARRAY  ICOMMAREA(*) = COMMAREA;                        <<06915>>61490000
DOUBLE  ARRAY  DCOMMAREA(*) = COMMAREA;                        <<06915>>61495000
                                                               <<06915>>61500000
BYTE    ARRAY  B'BUFFER(*) = BUFFER;                           <<06915>>61505000
                                                               <<06915>>61510000
INTEGER ERRORCODE, BUFFERCOUNT, MOVECOUNT;                     <<06915>>61515000
INTEGER EXPMOVECOUNT;                                          <<06915>>61520000
                                                               <<06915>>61525000
LOGICAL NEEDRECORD;                                            <<06915>>61530000
                                                               <<06915>>61535000
EQUATE  RECIDLEN = 3;                                          <<06915>>61540000
                                                               <<06915>>61545000
EQUATE  FIRSTRECORDINBLOCK = 0;                                <<06915>>61550000
DOUBLE  FIRSTBLOCK := 0D;                                      <<06915>>61555000
                                                               <<06915>>61560000
DOUBLE  POINTER RECID'BLOCK  := @RECID;                        <<06915>>61565000
DEFINE          RECID'RECORD = RECID(2)#;                      <<06915>>61570000
                                                               <<06915>>61575000
EQUATE  FWRITECODE     = 1;                                    <<06915>>61580000
EQUATE  NRJECODE    = 193;                                     <<07064>>61585000
                                                               <<07064>>61590000
EQUATE  DATATYPE = 0;                                          <<07064>>61595000
EQUATE  PDIRTYPE = 1;                                          <<07064>>61600000
                                                               <<06915>>61605000
INTRINSIC FREADDIR, FCHECK, QUIT, ARITRAP;                     <<06915>>61610000
                                                               <<06915>>61615000
<<----------------------- EXIT ------------------------>>      <<06915>>61620000
<< Reset critical.  Record reason for return.  Return  >>      <<06915>>61625000
<< from procedure.                                     >>      <<06915>>61630000
<<----------------------------------------------------->>      <<06915>>61635000
SUBROUTINE EXIT( REASON );                                     <<06915>>61640000
VALUE REASON; INTEGER REASON;                                  <<06915>>61645000
BEGIN                                                          <<06915>>61650000
                                                               <<06915>>61655000
RESETCRITICAL(CRIT);                                           <<06915>>61660000
                                                               <<06915>>61665000
ARITRAP(TRUE);                                                 <<06915>>61670000
                                                               <<06915>>61675000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>61680000
   ( REASON = BADDB                          ) THEN            <<06915>>61685000
  QUIT(REASON);                                                <<06915>>61690000
                                                               <<06915>>61695000
STATUS := REASON;                                              <<06915>>61700000
                                                               <<06915>>61705000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>61710000
                                                               <<06915>>61715000
END;<< SUBROUTINE EXIT >>                                      <<06915>>61720000
                                                               <<06915>>61725000
<<----------------- INITIAL --------------------------->>      <<06915>>61730000
<< Set critical.  Return error if called in split stack>>      <<06915>>61735000
<< mode or reference parameter out of bounds.  Initial->>      <<06915>>61740000
<< ize trunccount and expancount parameters.  Change   >>      <<06915>>61745000
<< incount to positive byte count.                     >>      <<06915>>61750000
<<----------------------------------------------------->>      <<06915>>61755000
SUBROUTINE INITIAL;                                            <<06915>>61760000
BEGIN                                                          <<06915>>61765000
                                                               <<06915>>61770000
ARITRAP(FALSE);                                                <<06915>>61775000
                                                               <<06915>>61780000
CRIT := SETCRITICAL;                                           <<06915>>61785000
                                                               <<06915>>61790000
TRUNCCOUNT := 0;                                               <<06915>>61795000
                                                               <<06915>>61800000
EXPANCOUNT := 0;                                               <<06915>>61805000
                                                               <<06915>>61810000
RECTYPE := DATATYPE;                                           <<07064>>61815000
                                                                        61820000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>61825000
                                                               <<06915>>61830000
BUFFERCOUNT := IF INCOUNT < 0 THEN -INCOUNT                    <<06915>>61835000
               ELSE INCOUNT * BYTESPERWORD;                    <<06915>>61840000
                                                               <<06915>>61845000
IF ( NOT FBNDCHK( @STATUS,             1, @QMINUSPARMS ) ) OR  <<06915>>61850000
   ( NOT FBNDCHK( @TRUNCCOUNT,         1, @QMINUSPARMS ) ) OR  <<06915>>61855000
   ( NOT FBNDCHK( @EXPANCOUNT,         1, @QMINUSPARMS ) ) OR  <<06915>>61860000
   ( NOT FBNDCHK( @RECTYPE,           1, @QMINUSPARMS  ) ) OR  <<07064>>61865000
   ( NOT FBNDCHK( @RECID,       RECIDLEN, @QMINUSPARMS ) ) OR  <<06915>>61870000
   ( NOT FBNDCHK( @BUFFER,                                     <<06915>>61875000
                  (BUFFERCOUNT + ROUNDUP)/BYTESPERWORD,        <<06915>>61880000
                  @QMINUSPARMS                         ) ) OR  <<06915>>61885000
   ( NOT FBNDCHK( @COMMAREA,                                   <<06915>>61890000
                  SIZE'OF'COMMAREA,                            <<06915>>61895000
                  @QMINUSPARMS                         ) ) THEN<<06915>>61900000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>61905000
                                                               <<06915>>61910000
END; << SUBROUTINE INITIAL >>                                  <<06915>>61915000
                                                               <<06915>>61920000
<<----------------- GETNEXTBLOCK ---------------------->>      <<06915>>61925000
<< Read next spool file block, resetting record index  >>      <<06915>>61930000
<< and incrementing block count.                       >>      <<06915>>61935000
<<----------------------------------------------------->>      <<06915>>61940000
SUBROUTINE GETNEXTBLOCK;                                       <<06915>>61945000
BEGIN                                                          <<06915>>61950000
                                                               <<06915>>61955000
SPBLOCK'BLOCKNUM := SPBLOCK'BLOCKNUM + 1D;                     <<06915>>61960000
                                                               <<06915>>61965000
FREADDIR(FNUM, COMMAREA, SIZE'OF'SPBLOCK, SPBLOCK'BLOCKNUM);   <<06915>>61970000
IF <> THEN                                                     <<06915>>61975000
BEGIN                                                          <<06915>>61980000
  FCHECK( FNUM, ERRORCODE );                                   <<06915>>61985000
  IF ERRORCODE = 0 THEN EXIT(ENDOFSPOOLFILE)                   <<06915>>61990000
  ELSE EXIT(ERRORCODE);                                        <<06915>>61995000
END;                                                           <<06915>>62000000
                                                               <<06915>>62005000
SPBLOCK'RECORDPOINTER := FIRSTRECORDINBLOCK;                   <<06915>>62010000
                                                               <<06915>>62015000
END;                                                           <<06915>>62020000
                                                               <<06915>>62025000
<<----------------- MOVERECORD ------------------------>>      <<06915>>62030000
<< Record carriage control.  Move record data into buf->>      <<06915>>62035000
<< fer.  Record data transferred, the actual amount of >>      <<06915>>62040000
<< data in record (including truncated blanks), and    >>      <<06915>>62045000
<< the record index and block count of the record.     >>      <<06915>>62050000
<<----------------------------------------------------->>      <<06915>>62055000
SUBROUTINE MOVERECORD;                                         <<06915>>62060000
BEGIN                                                          <<06915>>62065000
                                                               <<06915>>62070000
MOVECOUNT := IF BUFFERCOUNT < SPRECORD'TRUNCDATACOUNT          <<06915>>62075000
             THEN BUFFERCOUNT                                  <<06915>>62080000
             ELSE SPRECORD'TRUNCDATACOUNT;                     <<06915>>62085000
                                                               <<06915>>62090000
MOVE BUFFER := SPRECORD'DATA,                                  <<06915>>62095000
               ( (MOVECOUNT + ROUNDUP) / BYTESPERWORD );       <<06915>>62100000
                                                               <<06915>>62105000
TRUNCCOUNT := IF INCOUNT < 0 THEN MOVECOUNT                    <<06915>>62110000
              ELSE (MOVECOUNT+ROUNDUP)/BYTESPERWORD;           <<06915>>62115000
                                                               <<06915>>62120000
EXPANCOUNT := IF INCOUNT < 0 THEN SPRECORD'EXPDATACOUNT        <<06915>>62125000
              ELSE (SPRECORD'EXPDATACOUNT+ROUNDUP)/            <<06915>>62130000
                   BYTESPERWORD;                               <<06915>>62135000
                                                               <<06915>>62140000
IF ( INCOUNT > 0                      ) AND                    <<06915>>62145000
   ( MOVECOUNT MOD BYTESPERWORD <> 0  ) THEN                   <<06915>>62150000
  B'BUFFER(MOVECOUNT) := " ";                                  <<06915>>62155000
                                                               <<06915>>62160000
RECID'BLOCK := SPBLOCK'BLOCKNUM;                               <<06915>>62165000
                                                               <<06915>>62170000
RECID'RECORD  := SPBLOCK'RECORDPOINTER;                        <<06915>>62175000
                                                               <<06915>>62180000
                                                               <<06915>>62185000
END;  << SUBROUTINE MOVERECORD >>                              <<06915>>62190000
                                                               <<06915>>62195000
<<------------------- NRJESPOOLREAD ------------------->>      <<06915>>62200000
                                                               <<06915>>62205000
                                                               <<06915>>62210000
<< 1. >>                                                       <<06915>>62215000
INITIAL;                                                       <<06915>>62220000
                                                               <<06915>>62225000
<< 2. >>                                                       <<06915>>62230000
NEEDRECORD := TRUE;                                            <<06915>>62235000
                                                               <<06915>>62240000
WHILE NEEDRECORD  DO                                           <<06915>>62245000
BEGIN                                                          <<06915>>62250000
                                                               <<06915>>62255000
 WHILE  ( SPRECORD'ENDOFBLOCKFLAG <> ENDOFBLOCK ) AND          <<06915>>62260000
        ( NEEDRECORD                            ) DO           <<06915>>62265000
                                                               <<06915>>62270000
    IF SPRECORD'FUNCTIONCODE = FWRITECODE THEN                 <<07064>>62275000
    BEGIN                                                      <<07064>>62280000
      NEEDRECORD := FALSE;                                     <<07064>>62285000
      RECTYPE := DATATYPE;                                     <<07064>>62290000
      MOVERECORD;                                              <<07064>>62295000
    END                                                        <<07064>>62300000
    ELSE IF SPRECORD'FUNCTIONCODE = NRJECODE THEN              <<07064>>62305000
    BEGIN                                                      <<07064>>62310000
      NEEDRECORD := FALSE;                                     <<07064>>62315000
      RECTYPE := PDIRTYPE;                                     <<07064>>62320000
      MOVERECORD;                                              <<07064>>62325000
    END                                                        <<07064>>62330000
    ELSE SPBLOCK'RECORDPOINTER := SPBLOCK'RECORDPOINTER +      <<07064>>62335000
     (SPRECORD'COUNT+ROUNDUP)/BYTESPERWORD;<<INNER WHILE LOOP>><<07064>>62340000
                                                               <<06915>>62345000
 IF NEEDRECORD THEN GETNEXTBLOCK;                              <<06915>>62350000
                                                               <<06915>>62355000
END;  << OUTER WHILE LOOP >>                                   <<06915>>62360000
                                                               <<06915>>62365000
SPBLOCK'RECORDPOINER := SPBLOCK'RECORDPOINTER +                <<06915>>62370000
  (SPRECORD'COUNT + ROUNDUP) / BYTESPERWORD;                   <<06915>>62375000
                                                               <<06915>>62380000
EXIT(OK);                                                      <<06915>>62385000
                                                               <<06915>>62390000
END;  << PROCEDURE NRJESPOOLREAD >>                            <<06915>>62395000
$PAGE                                                          <<06915>>62400000
COMMENT:                                                       <<06915>>62405000
+-------------------------------------------------------+      <<06915>>62410000
|                       |                               |      <<06915>>62415000
| NRJESPOOLCLOSE        |  Algorithm                    |      <<06915>>62420000
|                       |                               |      <<06915>>62425000
| NRJESPOOLCLOSE per-   |  1. Return error if called in |      <<06915>>62430000
| forms an fsclose on an|     split stack mode or ref-  |      <<06915>>62435000
| opened spool file.    |     erence parameter out of   |      <<06915>>62440000
|                       |     bounds.                   |      <<06915>>62445000
| Input                 |                               |      <<06915>>62450000
|                       |  2. Call fsclose to close the |      <<06915>>62455000
| FNUM                  |     spool file.               |      <<06915>>62460000
|  File system no. which|                               |      <<06915>>62465000
|  identifies an opened |                               |      <<06915>>62470000
|  spool file           |                               |      <<06915>>62475000
| DISPOSITION           |                               |      <<06915>>62480000
|  Same as FCLOSE dis-  |                               |      <<06915>>62485000
|  position parameter   |                               |      <<06915>>62490000
| SECCODE               |                               |      <<06915>>62495000
|  Same as FCLOSE se-   |                               |      <<06915>>62500000
|  curity code          |                               |      <<06915>>62505000
|                       |                               |      <<06915>>62510000
| Output                |                               |      <<06915>>62515000
|                       |                               |      <<06915>>62520000
| STATUS                |                               |      <<06915>>62525000
|  no errors     - 0    |                               |      <<06915>>62530000
|  baddb         - -12  |                               |      <<06915>>62535000
|  parmoutbounds - -10  |                               |      <<06915>>62540000
|  file system error    |                               |      <<06915>>62545000
|  code.                |                               |      <<06915>>62550000
+-------------------------------------------------------+      <<06915>>62555000
END OF COMMENT;                                                <<06915>>62560000
                                                               <<06915>>62565000
PROCEDURE NRJESPOOLCLOSE(  FNUM,           << INPUT  >>        <<06915>>62570000
                           DISPOSITION,    << INPUT  >>        <<06915>>62575000
                           SECCODE,        << INPUT  >>        <<06915>>62580000
                           STATUS          << OUTPUT >>        <<06915>>62585000
                        );                                     <<06915>>62590000
                                                               <<06915>>62595000
<<-------------------- PARAMETERS --------------------->>      <<06915>>62600000
                                                               <<06915>>62605000
VALUE         FNUM, DISPOSITION, SECCODE;                      <<06915>>62610000
INTEGER       FNUM, DISPOSITION, SECCODE, STATUS;              <<06915>>62615000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>62620000
                                                               <<06915>>62625000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>62630000
                                                               <<06915>>62635000
BEGIN                                                          <<06915>>62640000
                                                               <<06915>>62645000
EQUATE  NUMPARMS    = 4,                                       <<06915>>62650000
        QMARKERLEN  = 4,                                       <<06915>>62655000
        MARKERNPARMS= NUMPARMS + QMARKERLEN;                   <<06915>>62660000
        << Maximum DB relative address of reference    >>      <<06915>>62665000
        << parameter is one word below location which  >>      <<06915>>62670000
        << contains value/address of 1st parameter.    >>      <<06915>>62675000
                                                               <<06915>>62680000
INTEGER XREG = X;                                              <<06915>>62685000
                                                               <<06915>>62690000
LOGICAL CRIT;                                                  <<06915>>62695000
                                                               <<06915>>62700000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>62705000
                                                               <<06915>>62710000
INTEGER ERRORCODE;                                             <<06915>>62715000
                                                               <<06915>>62720000
INTRINSIC FCHECK, QUIT, ARITRAP;                               <<06915>>62725000
                                                               <<06915>>62730000
<<----------------------- EXIT ------------------------>>      <<06915>>62735000
<< Reset critical.  Record reason for return.  Return  >>      <<06915>>62740000
<< from procedure.                                     >>      <<06915>>62745000
<<----------------------------------------------------->>      <<06915>>62750000
SUBROUTINE EXIT( REASON );                                     <<06915>>62755000
VALUE REASON; INTEGER REASON;                                  <<06915>>62760000
BEGIN                                                          <<06915>>62765000
                                                               <<06915>>62770000
RESETCRITICAL(CRIT);                                           <<06915>>62775000
                                                               <<06915>>62780000
ARITRAP(TRUE);                                                 <<06915>>62785000
                                                               <<06915>>62790000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>62795000
   ( REASON = BADDB                          ) THEN            <<06915>>62800000
  QUIT(REASON);                                                <<06915>>62805000
                                                               <<06915>>62810000
STATUS := REASON;                                              <<06915>>62815000
                                                               <<06915>>62820000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>62825000
                                                               <<06915>>62830000
END;  << SUBROUTINE EXIT >>                                    <<06915>>62835000
                                                               <<06915>>62840000
<<-------------------- INITIAL ------------------------>>      <<06915>>62845000
<< Set critical.  Return error if called in split stack>>      <<06915>>62850000
<< mode or reference parameter out of bounds.          >>      <<06915>>62855000
<<----------------------------------------------------->>      <<06915>>62860000
SUBROUTINE INITIAL;                                            <<06915>>62865000
BEGIN                                                          <<06915>>62870000
                                                               <<06915>>62875000
ARITRAP(FALSE);                                                <<06915>>62880000
                                                               <<06915>>62885000
CRIT := SETCRITICAL;                                           <<06915>>62890000
                                                               <<06915>>62895000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>62900000
                                                               <<06915>>62905000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     ) THEN        <<06915>>62910000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>62915000
                                                               <<06915>>62920000
END; << SUBROUTINE INITIAL >>                                  <<06915>>62925000
                                                               <<06915>>62930000
<<------------------- NRJESPOOLCLOSE ------------------>>      <<06915>>62935000
                                                               <<06915>>62940000
                                                               <<06915>>62945000
<< 1. >>                                                       <<06915>>62950000
INITIAL;                                                       <<06915>>62955000
                                                               <<06915>>62960000
<< 2. >>                                                       <<06915>>62965000
FSCLOSE( FNUM, DISPOSITION, SECCODE );                         <<06915>>62970000
IF < THEN                                                      <<06915>>62975000
BEGIN                                                          <<06915>>62980000
  FCHECK( FNUM, ERRORCODE );                                   <<06915>>62985000
  EXIT( ERRORCODE );                                           <<06915>>62990000
END;                                                           <<06915>>62995000
                                                               <<06915>>63000000
EXIT(OK);                                                      <<06915>>63005000
                                                               <<06915>>63010000
END;  << PROCEDURE NRJESPOOLCLOSE >>                           <<06915>>63015000
$PAGE                                                          <<06915>>63020000
COMMENT:                                                       <<06915>>63025000
+--------------------------------------------------+           <<06915>>63030000
|                       |                          |           <<06915>>63035000
| NRJESPOOLREWIND       | Algorithm                |           <<06915>>63040000
|                       |                          |           <<06915>>63045000
| NRJESPOOLREWIND re-   | 1. Return error if called|           <<06915>>63050000
| winds a spool file    |    with split stack, ref.|           <<06915>>63055000
| to the record identi- |    parm out of bounds, or|           <<06915>>63060000
| fied by recid param-  |    bad record id.        |           <<06915>>63065000
| eter.  After perform- |                          |           <<06915>>63070000
| ing a rewind, NRJE-   | 2. Read block to be      |           <<06915>>63075000
| SPOOLREAD can be call-|    "rewound" to.         |           <<06915>>63080000
| ed to perform sequen- |                          |           <<06915>>63085000
| tial reads starting at| 3. Reset record and block|           <<06915>>63090000
| the record NRJESPOOL- |    pointers in commarea. |           <<06915>>63095000
| REWIND rewound to.    |                          |           <<06915>>63100000
|                       |                          |           <<06915>>63105000
| Input                 | Output                   |           <<06915>>63110000
|                       |                          |           <<06915>>63115000
| FNUM                  | STATUS                   |           <<06915>>63120000
|  file system number   |  no errors      -  0     |           <<06915>>63125000
|  which identifies an  |  endofspoolfile -  -13   |           <<06915>>63130000
|  opened spool file    |  baddb          -  -12   |           <<06915>>63135000
| COMMAREA              |  parmoutbounds  -  -10   |           <<06915>>63140000
|  an area used by NRJE-|  badrecid       -  -17   |           <<06915>>63145000
|  SPOOLREWIND for glo- |  file system errors      |           <<06915>>63150000
|  bal storage          |                          |           <<06915>>63155000
| RECID                 |                          |           <<06915>>63160000
|  3 word identifier    |                          |           <<06915>>63165000
|  obtained from NRJE-  |                          |           <<06915>>63170000
|  SPOOLREAD which in-  |                          |           <<06915>>63175000
|  dicates which record |                          |           <<06915>>63180000
|  to rewind to         |                          |           <<06915>>63185000
|                       |                          |           <<06915>>63190000
+--------------------------------------------------+           <<06915>>63195000
END OF COMMENT;                                                <<06915>>63200000
                                                               <<06915>>63205000
PROCEDURE NRJESPOOLREWIND( FNUM,     << INPUT  >>              <<06915>>63210000
                           COMMAREA, << INPUT  >>              <<06915>>63215000
                           RECID,    << INPUT  >>              <<06915>>63220000
                           STATUS    << OUTPUT >>              <<06915>>63225000
                         );                                    <<06915>>63230000
                                                               <<06915>>63235000
<<------------------- PARAMETERS --------------------->>       <<06915>>63240000
                                                               <<06915>>63245000
VALUE         FNUM;                                            <<06915>>63250000
INTEGER       FNUM, STATUS;                                    <<06915>>63255000
LOGICAL ARRAY COMMAREA;                                        <<06915>>63260000
INTEGER ARRAY RECID;                                           <<06915>>63265000
OPTION PRIVILEGED, UNCALLABLE;                                 <<U7867>>63270000
                                                               <<06915>>63275000
<<--------------- LOCAL VARAIBLES -------------------->>       <<06915>>63280000
                                                               <<06915>>63285000
BEGIN                                                          <<06915>>63290000
                                                               <<06915>>63295000
EQUATE  NUMPARMS     = 4,                                      <<06915>>63300000
        QMARKERLEN   = 4,                                      <<06915>>63305000
        MARKERNPARMS = NUMPARMS + QMARKERLEN;                  <<06915>>63310000
        << Maximum DB relative address of a reference >>       <<06915>>63315000
        << parameter is one word below the location   >>       <<06915>>63320000
        << which contains address/value of 1st parm.  >>       <<06915>>63325000
                                                               <<06915>>63330000
INTEGER XREG = X;                                              <<06915>>63335000
                                                               <<06915>>63340000
LOGICAL CRIT;                                                  <<06915>>63345000
                                                               <<06915>>63350000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>63355000
                                                               <<06915>>63360000
INTEGER ARRAY ICOMMAREA(*) = COMMAREA;                         <<06915>>63365000
DOUBLE ARRAY  DCOMMAREA(*) = COMMAREA;                         <<06915>>63370000
                                                               <<06915>>63375000
EQUATE RECIDLEN = 3;                                           <<06915>>63380000
                                                               <<06915>>63385000
EQUATE FIRSTRECORDINBLOCK = 0;                                 <<06915>>63390000
                                                               <<06915>>63395000
DOUBLE POINTER RECID'BLOCK  := @RECID;                         <<06915>>63400000
DEFINE         RECID'RECORD =  RECID(2)#;                      <<06915>>63405000
                                                               <<06915>>63410000
INTEGER ERRORCODE;                                             <<06915>>63415000
                                                               <<06915>>63420000
INTRINSIC FREADDIR, FCHECK, QUIT, ARITRAP;                     <<06915>>63425000
                                                               <<06915>>63430000
<<---------------------- EXIT ------------------------>>       <<06915>>63435000
<< Reset critical.  Record reason for return.  Return >>       <<06915>>63440000
<< from procedure or abort.                           >>       <<06915>>63445000
<<---------------------------------------------------->>       <<06915>>63450000
SUBROUTINE EXIT( REASON );                                     <<06915>>63455000
VALUE REASON; INTEGER REASON;                                  <<06915>>63460000
BEGIN                                                          <<06915>>63465000
                                                               <<06915>>63470000
RESETCRITICAL(CRIT);                                           <<06915>>63475000
                                                               <<06915>>63480000
ARITRAP(TRUE);                                                 <<06915>>63485000
                                                               <<06915>>63490000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>63495000
   ( REASON = BADDB                          ) THEN            <<06915>>63500000
  QUIT( REASON );                                              <<06915>>63505000
                                                               <<06915>>63510000
STATUS := REASON;                                              <<06915>>63515000
                                                               <<06915>>63520000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>63525000
                                                               <<06915>>63530000
END; << SUBROUTINE EXIT >>                                     <<06915>>63535000
                                                               <<06915>>63540000
<<-------------------- INITIAL ----------------------->>       <<06915>>63545000
<< Set critical.  Return error if called in split     >>       <<06915>>63550000
<< stack mode or reference parameter out of bounds.   >>       <<06915>>63555000
<<---------------------------------------------------->>       <<06915>>63560000
SUBROUTINE INITIAL;                                            <<06915>>63565000
BEGIN                                                          <<06915>>63570000
                                                               <<06915>>63575000
ARITRAP(FALSE);                                                <<06915>>63580000
                                                               <<06915>>63585000
CRIT := SETCRITICAL;                                           <<06915>>63590000
                                                               <<06915>>63595000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>63600000
                                                               <<06915>>63605000
IF ( NOT FBNDCHK( @STATUS,             1, @QMINUSPARMS ) ) OR  <<06915>>63610000
   ( NOT FBNDCHK( @COMMAREA,                                   <<06915>>63615000
                  SIZE'OF'COMMAREA,                            <<06915>>63620000
                  @QMINUSPARMS                         ) ) OR  <<06915>>63625000
   ( NOT FBNDCHK( @RECID,       RECIDLEN, @QMINUSPARMS ) ) THEN<<06915>>63630000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>63635000
                                                               <<06915>>63640000
IF NOT ( FIRSTRECORDINBLOCK <= RECID'RECORD                    <<06915>>63645000
         <= (SIZE'OF'SPBLOCK - 1)             ) THEN           <<06915>>63650000
  EXIT(BADRECID);                                              <<06915>>63655000
                                                               <<06915>>63660000
END; << SUBROUTINE INITIAL >>                                  <<06915>>63665000
                                                               <<06915>>63670000
<<--------------- NRJESPOOLREWIND -------------------->>       <<06915>>63675000
                                                               <<06915>>63680000
                                                               <<06915>>63685000
<< 1. >>                                                       <<06915>>63690000
INITIAL;                                                       <<06915>>63695000
                                                               <<06915>>63700000
<< 2. >>                                                       <<06915>>63705000
FREADDIR(FNUM, COMMAREA, SIZE'OF'SPBLOCK, RECID'BLOCK);        <<06915>>63710000
IF <> THEN                                                     <<06915>>63715000
BEGIN                                                          <<06915>>63720000
  FCHECK( FNUM, ERRORCODE );                                   <<06915>>63725000
  IF ERRORCODE = 0 THEN EXIT(ENDOFSPOOLFILE)                   <<06915>>63730000
  ELSE EXIT(ERRORCODE);                                        <<06915>>63735000
END;                                                           <<06915>>63740000
                                                               <<06915>>63745000
<< 3. >>                                                       <<06915>>63750000
SPBLOCK'BLOCKNUM := RECID'BLOCK;                               <<06915>>63755000
SPBLOCK'RECORDPOINTER := RECID'RECORD;                         <<06915>>63760000
                                                               <<06915>>63765000
EXIT(OK);                                                      <<06915>>63770000
                                                               <<06915>>63775000
END; << PROCEDURE NRJESPOOLREWIND >>                           <<06915>>63780000
$PAGE                                                          <<06915>>63785000
COMMENT:                                                       <<06915>>63790000
+-------------------------------------------------------+      <<06915>>63795000
|                       |                               |      <<06915>>63800000
| NRJEDEVCLASSES/       | Algorithm                     |      <<06915>>63805000
|  DEVCLASSES           |                               |      <<06915>>63810000
|                       | 1. Return error if called in  |      <<06915>>63815000
| NRJE/DEVCLASSES return|    split stack mode, or call  |      <<06915>>63820000
| the device class names|    by reference parameter is  |      <<06915>>63825000
| and indices associated|    out of bounds. Initialize  |      <<06915>>63830000
| with the device pass- |    numclasses.                |      <<06915>>63835000
| ed.  NRJEDEVCLASSES   |                               |      <<06915>>63840000
| checks that the dev.  | 2. Loop through DCT, record-  |      <<06915>>63845000
| is an NRJE reader.    |    ing names/indices of class-|      <<06915>>63850000
|                       |    es associated with the     |      <<06915>>63855000
| Input                 |    device passed.  If more    |      <<06915>>63860000
|                       |    classes are found than the |      <<06915>>63865000
| DEVICE                |    caller requested, don't    |      <<06915>>63870000
|  no. of an MPE logical|    record extra names/indices |      <<06915>>63875000
|  device               |    but continue search and    |      <<06915>>63880000
| MAXCLASSES            |    return no. of classes      |      <<06915>>63885000
|  max. no. of class    |    found.                     |      <<06915>>63890000
|  names/indices return |                               |      <<06915>>63895000
|                       |                               |      <<06915>>63900000
| Output                |                               |      <<06915>>63905000
|                       |                               |      <<06915>>63910000
| DEVCLASSES            |                               |      <<06915>>63915000
|  array of 4 word      |                               |      <<06915>>63920000
|  device class names   |                               |      <<06915>>63925000
| CLASSINDICES          |                               |      <<06915>>63930000
|  array of class in-   |                               |      <<06915>>63935000
|  dices stored in same |                               |      <<06915>>63940000
|  order as class names |                               |      <<06915>>63945000
| NUMCLASSES            |                               |      <<06915>>63950000
|  the number of classes|                               |      <<06915>>63955000
|  associated with a    |                               |      <<06915>>63960000
|  device               |                               |      <<06915>>63965000
| STATUS                |                               |      <<06915>>63970000
|  no errors       - 0  |                               |      <<06915>>63975000
|  parmoutbounds   - -10|                               |      <<06915>>63980000
|  baddev          - -12|                               |      <<06915>>63985000
|  classnotassoc1dev    |                               |      <<06915>>63990000
|                  - -15|                               |      <<06915>>63995000
|                       |                               |      <<06915>>64000000
|                       |                               |      <<06915>>64005000
|                       |                               |      <<06915>>64010000
|                       |                               |      <<06915>>64015000
+-------------------------------------------------------+      <<06915>>64020000
END OF COMMENT;                                                <<06915>>64025000
                                                               <<06915>>64030000
PROCEDURE  DEVCLASSES(  DEVICE,       << INPUT  >>             <<06915>>64035000
                        MAXCLASSES,   << INPUT  >>             <<06915>>64040000
                        DEVCLASSES,   << OUTPUT >>             <<06915>>64045000
                        CLASSINDICES, << OUTPUT >>             <<06915>>64050000
                        NUMCLASSES,   << OUTPUT >>             <<06915>>64055000
                        STATUS        << OUTPUT >>             <<06915>>64060000
                     );                                        <<06915>>64065000
                                                               <<06915>>64070000
<<-------------------- PARAMETERS --------------------->>      <<06915>>64075000
                                                               <<06915>>64080000
VALUE         DEVICE, MAXCLASSES;                              <<06915>>64085000
INTEGER       DEVICE, MAXCLASSES, NUMCLASSES, STATUS;          <<06915>>64090000
INTEGER ARRAY CLASSINDICES;                                    <<06915>>64095000
LOGICAL ARRAY DEVCLASSES;                                      <<06915>>64100000
OPTION        PRIVILEGED, UNCALLABLE;                          <<06915>>64105000
                                                               <<06915>>64110000
<<-------------------LOCAL VARIABLES ------------------>>      <<06915>>64115000
                                                               <<06915>>64120000
BEGIN                                                          <<06915>>64125000
                                                               <<06915>>64130000
EQUATE  NUMPARMS     = 6,                                      <<06915>>64135000
        QMARKERLEN   = 4,                                      <<06915>>64140000
        MARKERNPARMS = NUMPARMS + QMARKERLEN;                  <<06915>>64145000
        << Maximum DB relative address of a reference  >>      <<06915>>64150000
        << parameter is one word below the location    >>      <<06915>>64155000
        << which contains value or address of 1st parm.>>      <<06915>>64160000
                                                               <<06915>>64165000
INTEGER XREG = X;                                              <<06915>>64170000
                                                               <<06915>>64175000
LOGICAL CRIT;                                                  <<06915>>64180000
                                                               <<06915>>64185000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>64190000
                                                               <<06915>>64195000
ENTRY   NRJEDEVCLASSES;                                        <<06915>>64200000
                                                               <<06915>>64205000
LOGICAL DEVCLASSESCALL := FALSE;                               <<06915>>64210000
                                                               <<06915>>64215000
                                                               <<06915>>64220000
INTEGER LPDT'INDEX, LDT'INDEX;                                 <<06915>>64225000
                                                               <<06915>>64230000
EQUATE  DISKORNULLTYPE = 0;                                    <<06915>>64235000
                                                               <<06915>>64240000
INTEGER POINTER DCT;                                           <<06915>>64245000
BYTE POINTER DCT'B;                                            <<06915>>64250000
                                                               <<06915>>64255000
INTEGER ARRAY DCT'HEAD(*) = DB + 0;                            <<06915>>64260000
INTEGER ARRAY LDT(*) = DB + 0;                                 <<06915>>64265000
                                                               <<06915>>64270000
DEFINE LDTDCTBASE       = LDT(1)#,                             <<06915>>64275000
       LDTNUMDCTENTRIES = LDT(2)#,                             <<06915>>64280000
       DCTHDCTBASE      = DCT'HEAD(3)#,                        <<06915>>64285000
       DCTHNUMDCTENTRIES= DCT'HEAD(2)#,                        <<06915>>64290000
       DCTDST           = 40#;                                 <<06915>>64295000
                                                               <<06915>>64300000
INTEGER NUM'ENTRIES;                                           <<06915>>64305000
                                                               <<06915>>64310000
INTEGER CLASSINDEX;                                            <<06915>>64315000
                                                               <<06915>>64320000
INTEGER CLASSCOUNT;                                            <<06915>>64325000
                                                               <<06915>>64330000
INTEGER DEVINDEX;                                              <<06915>>64335000
                                                               <<06915>>64340000
DEFINE  DEVCLASSDST = IF LDT'MPE'VERSION = 4                   <<06915>>64345000
              THEN LDT'DST                                     <<06915>>64350000
              ELSE DCTDST#;                                    <<06915>>64355000
                                                               <<06915>>64360000
DEFINE  CLASSDEVICE = IF LDT'MPE'VERSION = 4                   <<06915>>64365000
              THEN INTEGER(DCT'B(DCT'FIRST'LDEV + DEVINDEX))   <<06915>>64370000
              ELSE DCT(DCT'FIRST'LDEV + DEVINDEX)#;            <<06915>>64375000
                                                               <<06915>>64380000
DEFINE  NUM'DCT'ENTRIES = IF LDT'MPE'VERSION = 4               <<06915>>64385000
              THEN LDTNUMDCTENTRIES                            <<06915>>64390000
              ELSE DCTHNUMDCTENTRIES#;                         <<06915>>64395000
                                                               <<06915>>64400000
DEFINE  DCT'BASE = IF LDT'MPE'VERSION = 4                      <<06915>>64405000
              THEN LDTDCTBASE                                  <<06915>>64410000
              ELSE DCTHDCTBASE#;                               <<06915>>64415000
                                                               <<06915>>64420000
EQUATE WORDSPERCLASS = 4;                                      <<06915>>64425000
                                                               <<06915>>64430000
INTRINSIC QUIT, ARITRAP;                                       <<06915>>64435000
                                                               <<06915>>64440000
<<---------------------- EXIT ------------------------->>      <<06915>>64445000
<< Reset critical.  Record reason for return.  Return  >>      <<06915>>64450000
<< from procedure.                                     >>      <<06915>>64455000
<<----------------------------------------------------->>      <<06915>>64460000
SUBROUTINE EXIT( REASON );                                     <<06915>>64465000
VALUE REASON; INTEGER REASON;                                  <<06915>>64470000
BEGIN                                                          <<06915>>64475000
                                                               <<06915>>64480000
RESETCRITICAL(CRIT);                                           <<06915>>64485000
                                                               <<06915>>64490000
ARITRAP(TRUE);                                                 <<06915>>64495000
                                                               <<06915>>64500000
IF ( NOT FBNDCHK( @STATUS, 1, @QMINUSPARMS )     )OR           <<06915>>64505000
   ( STATUS = BADDB                              ) THEN        <<06915>>64510000
  QUIT(REASON);                                                <<06915>>64515000
                                                               <<06915>>64520000
STATUS := REASON;                                              <<06915>>64525000
                                                               <<06915>>64530000
ASSEMBLE(EXIT NUMPARMS );                                      <<06915>>64535000
                                                               <<06915>>64540000
END;  << SUBROUTINE EXIT >>                                    <<06915>>64545000
                                                               <<06915>>64550000
<<-------------------- INITIAL ------------------------>>      <<06915>>64555000
<< Set critical.  Return error if called in split stack>>      <<06915>>64560000
<< mode, or reference parameter is out of bounds.      >>      <<06915>>64565000
<< Initialize numclasses.                              >>      <<06915>>64570000
<<----------------------------------------------------->>      <<06915>>64575000
SUBROUTINE INITIAL;                                            <<06915>>64580000
BEGIN                                                          <<06915>>64585000
                                                               <<06915>>64590000
ARITRAP(FALSE);                                                <<06915>>64595000
                                                               <<06915>>64600000
CRIT := SETCRITICAL;                                           <<06915>>64605000
                                                               <<06915>>64610000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>64615000
                                                               <<06915>>64620000
IF ( NOT FBNDCHK( @STATUS,             1, @QMINUSPARMS ) ) OR  <<06915>>64625000
   ( NOT FBNDCHK( @NUMCLASSES,         1, @QMINUSPARMS ) ) OR  <<06915>>64630000
   ( NOT FBNDCHK( @DEVCLASSES,                                 <<06915>>64635000
                  MAXCLASSES * WORDSPERCLASS,                  <<06915>>64640000
                  @QMINUSPARMS                         ) ) OR  <<06915>>64645000
   ( NOT FBNDCHK( @CLASSINDICES,                               <<06915>>64650000
                  MAXCLASSES,                                  <<06915>>64655000
                  @QMINUSPARMS                         ) )THEN <<06915>>64660000
  EXIT(PARMOUTBOUNDS);                                         <<06915>>64665000
                                                               <<06915>>64670000
                                                               <<06915>>64675000
IF DEVICE < LDEVMIN THEN EXIT(BADDEV);                         <<06915>>64680000
                                                               <<06915>>64685000
                                                               <<06915>>64690000
LDT'INDEX := DEVICE * SIZE'OF'LDT'ENTRY;                       <<06915>>64695000
LPDT'INDEX := DEVICE * SIZE'OF'LPDT'ENTRY;                     <<06915>>64700000
                                                               <<06915>>64705000
EXCHANGEDB(LDT'DST);                                           <<06915>>64710000
                                                               <<06915>>64715000
IF DEVICE > LDT'NUM'ENTRIES THEN                               <<06915>>64720000
BEGIN                                                          <<06915>>64725000
  EXCHANGEDB(0);                                               <<06915>>64730000
  EXIT(BADDEV);                                                <<06915>>64735000
END;                                                           <<06915>>64740000
                                                               <<06915>>64745000
IF (LDT'DEVICE'TYPE  =  DISKORNULLTYPE) AND                    <<06915>>64750000
   (LDT'RECORD'WIDTH = 0              ) THEN                   <<06915>>64755000
BEGIN                                                          <<06915>>64760000
  EXCHANGEDB(0);                                               <<06915>>64765000
  EXIT(BADDEV);                                                <<06915>>64770000
END;                                                           <<06915>>64775000
                                                               <<06915>>64780000
IF (NOT DEVCLASSESCALL           ) AND                         <<06915>>64785000
   (LDT'DEVICE'TYPE <> NRJETYPE  ) THEN                        <<06915>>64790000
BEGIN                                                          <<06915>>64795000
  EXCHANGEDB(0);                                               <<06915>>64800000
  EXIT(BADDEV);                                                <<06915>>64805000
END;                                                           <<06915>>64810000
                                                               <<06915>>64815000
EXCHANGEDB(0);                                                 <<06915>>64820000
                                                               <<06915>>64825000
IF (NOT DEVCLASSESCALL                    ) AND                <<B7518>>64830000
   (INTEGER (LPDT'SUBTYPE) <> NRJESUBTYPE ) THEN               <<B7518>>64835000
BEGIN                                                          <<06915>>64840000
  EXIT(BADDEV);                                                <<06915>>64845000
END;                                                           <<06915>>64850000
                                                               <<06915>>64855000
NUMCLASSES := 0;                                               <<06915>>64860000
                                                               <<06915>>64865000
END; << SUBROUTINE INITIAL >>                                  <<06915>>64870000
                                                               <<06915>>64875000
<<---------------- RECORDCLASS ------------------------>>      <<06915>>64880000
<< Store device class index in classindices array.     >>      <<06915>>64885000
<< Also, store device class name from dct to           >>      <<06915>>64890000
<< devclasses array.                                   >>      <<06915>>64895000
<<----------------------------------------------------->>      <<06915>>64900000
SUBROUTINE RECORDCLASS;                                        <<06915>>64905000
BEGIN                                                          <<06915>>64910000
                                                               <<06915>>64915000
EXCHANGEDB(0);                                                 <<06915>>64920000
                                                               <<06915>>64925000
CLASSINDICES(CLASSCOUNT) := CLASSINDEX;                        <<06915>>64930000
                                                               <<06915>>64935000
TOS := @DEVCLASSES(CLASSCOUNT * WORDSPERCLASS);                <<06915>>64940000
TOS := DEVCLASSDST;                                            <<06915>>64945000
TOS := WORDADDRESS (@DCTB'CLASS'NAME);                         <<B7518>>64950000
TOS := WORDSPERCLASS;                                          <<06915>>64955000
ASSEMBLE(MFDS 4);                                              <<06915>>64960000
                                                               <<06915>>64965000
EXCHANGEDB(DEVCLASSDST);                                       <<06915>>64970000
                                                               <<06915>>64975000
END;  << SUBROUTINE RECORDCLASS >>                             <<06915>>64980000
                                                               <<06915>>64985000
                                                               <<06915>>64990000
<<---------------------- DEVCLASSES ------------------->>      <<06915>>64995000
                                                               <<06915>>65000000
                                                               <<06915>>65005000
DEVCLASSESCALL := TRUE;                                        <<06915>>65010000
                                                               <<06915>>65015000
NRJEDEVCLASSES:                                                <<06915>>65020000
                                                               <<06915>>65025000
                                                               <<06915>>65030000
<< 1. >>                                                       <<06915>>65035000
INITIAL;                                                       <<06915>>65040000
                                                               <<06915>>65045000
                                                               <<06915>>65050000
<< 2. >>                                                       <<06915>>65055000
                                                               <<06915>>65060000
EXCHANGEDB(DEVCLASSDST);                                       <<06915>>65065000
                                                               <<06915>>65070000
CLASSCOUNT := 0;                                               <<06915>>65075000
CLASSINDEX := 1;                                               <<06915>>65080000
@DCT := DCT'BASE;                                              <<06915>>65085000
@DCT'B := @DCT & LSL(1);                                       <<06915>>65090000
NUM'ENTRIES := NUM'DCT'ENTRIES;                                <<06915>>65095000
                                                               <<06915>>65100000
WHILE ( CLASSINDEX <= NUM'ENTRIES ) DO                         <<06915>>65105000
BEGIN                                                          <<06915>>65110000
                                                               <<06915>>65115000
  DEVINDEX := 0;                                               <<06915>>65120000
  WHILE ( DEVINDEX < DCT'NUM'DEVICES ) DO                      <<06915>>65125000
  BEGIN                                                        <<06915>>65130000
                                                               <<06915>>65135000
    IF ((CLASSDEVICE) = DEVICE)THEN                            <<06915>>65140000
    BEGIN                                                      <<06915>>65145000
      IF DCT'NUM'DEVICES <> 1 THEN                             <<06915>>65150000
      BEGIN                                                    <<06915>>65155000
        EXCHANGEDB(0);                                         <<06915>>65160000
        EXIT(CLASSNOTASSOC1DEV);                               <<06915>>65165000
      END;                                                     <<06915>>65170000
      IF CLASSCOUNT < MAXCLASSES THEN                          <<06915>>65175000
        RECORDCLASS;                                           <<06915>>65180000
      CLASSCOUNT := CLASSCOUNT + 1;                            <<06915>>65185000
    END;                                                       <<06915>>65190000
                                                               <<06915>>65195000
    DEVINDEX := DEVINDEX + 1;                                  <<06915>>65200000
  END;                                                         <<06915>>65205000
                                                               <<06915>>65210000
                                                               <<06915>>65215000
  CLASSINDEX := CLASSINDEX + 1;                                <<06915>>65220000
  @DCT := @DCT + DCT'NEXT'ENTRY;                               <<06915>>65225000
  @DCT'B := @DCT & LSL(1);                                     <<06915>>65230000
                                                               <<06915>>65235000
END; << WHILE CLASSINDEX < DCT'ENTRIES >>                      <<06915>>65240000
                                                               <<06915>>65245000
EXCHANGEDB(0);                                                 <<06915>>65250000
                                                               <<06915>>65255000
NUMCLASSES := CLASSCOUNT;                                      <<06915>>65260000
EXIT(OK);                                                      <<06915>>65265000
                                                               <<06915>>65270000
END; << PROCEDURE NRJEDEVCLASSES >>                            <<06915>>65275000
$PAGE   "            PROGEN/NRJE   OPENQ   PROCEUDRE "         <<06915>>65280000
COMMENT:                                                       <<06915>>65285000
+----------------------------------------------------+         <<06915>>65290000
|                                                    |         <<06915>>65295000
|   PROCEDURE NRJEOPENQS                             |         <<06915>>65300000
|                                                    |         <<06915>>65305000
|   LOOPS THROUGH LDT/LPDT, LOOKING FOR NRJE READER  |         <<06915>>65310000
|   DEVICES.  SETS SPOOL QUEUEING ON FOR ALL NRJE    |         <<06915>>65315000
|   READER DEVICES.                                  |         <<06915>>65320000
|                                                    |         <<06915>>65325000
|   CALLED BY PROGEN                                 |         <<06915>>65330000
|                                                    |         <<06915>>65335000
+----------------------------------------------------+         <<06915>>65340000
END OF COMMENT;                                                <<06915>>65345000
                                                               <<06915>>65350000
PROCEDURE NRJEOPENQS;                                          <<06915>>65355000
OPTION    PRIVILEGED, UNCALLABLE;                              <<06915>>65360000
BEGIN                                                          <<06915>>65365000
                                                               <<06915>>65370000
<<---------- LOCAL VARIABLE DECLARATIONS ---------->>          <<06915>>65375000
                                                               <<06915>>65380000
INTEGER SAVELDT;                                               <<06915>>65385000
                                                               <<06915>>65390000
INTEGER LDT'INDEX, LPDT'INDEX;                                 <<06915>>65395000
                                                               <<06915>>65400000
INTEGER ARRAY LDT(*) = DB + 0;                                 <<06915>>65405000
                                                               <<06915>>65410000
                                                               <<06915>>65415000
INTEGER ELEMENT;                                               <<06915>>65420000
                                                               <<06915>>65425000
                                                               <<06915>>65430000
                                                               <<06915>>65435000
<<------------------ NRJEOPENQS ------------------->>          <<06915>>65440000
                                                               <<06915>>65445000
                                                               <<06915>>65450000
SAVELDT := GETSIR( LDT'SIR );                                  <<06915>>65455000
EXCHANGEDB( LDT'DST );                                         <<06915>>65460000
                                                               <<06915>>65465000
LDT'INDEX := 0;                                                <<07175>>65470000
ELEMENT := 1;                                                  <<06915>>65475000
                                                               <<06915>>65480000
WHILE ELEMENT <= LDT'NUM'ENTRIES DO                            <<06915>>65485000
BEGIN                                                          <<06915>>65490000
                                                               <<06915>>65495000
  LDT'INDEX := LDT'INDEX + SIZE'OF'LDT'ENTRY;                  <<06915>>65500000
                                                               <<06915>>65505000
  IF LDT'DEVICE'TYPE = NRJETYPE THEN                           <<06915>>65510000
  BEGIN                                                        <<06915>>65515000
    LPDT'INDEX := ELEMENT * SIZE'OF'LPDT'ENTRY;                <<06915>>65520000
    IF INTEGER (LPDT'SUBTYPE) = NRJESUBTYPE THEN               <<B7518>>65525000
      LDT'SPOOL'QUEUES := LDT'QOPEN;                           <<06915>>65530000
  END;                                                         <<06915>>65535000
                                                               <<06915>>65540000
ELEMENT := ELEMENT + 1;                                        <<06915>>65545000
END;                                                           <<06915>>65550000
                                                               <<06915>>65555000
EXCHANGEDB(0);                                                 <<06915>>65560000
                                                               <<06915>>65565000
RELSIR( LDT'SIR,  SAVELDT  );                                  <<06915>>65570000
                                                               <<06915>>65575000
END;  << PROCEDURE NRJEOPENQS >>                               <<06915>>65580000
$PAGE                                                          <<06915>>65585000
COMMENT:                                                       <<06915>>65590000
+--------------------------------------------------+           <<06915>>65595000
|                       |                          |           <<06915>>65600000
| NRJESPOOLSECTORS      | Algorithm                |           <<06915>>65605000
|                       |                          |           <<06915>>65610000
| NRJESPOOLSIZE returns | 1. Call quit if called in|           <<06915>>65615000
| the number of sectors |    split stack.          |           <<06915>>65620000
| per extent allocated  |                          |           <<06915>>65625000
| by the system admini- | 2. Return no. of sectors |           <<06915>>65630000
| strator during con-   |    in a spool file ex-   |           <<06915>>65635000
| figuration or sysdump.|    tent.                 |           <<06915>>65640000
|                       |                          |           <<06915>>65645000
| Output                |                          |           <<06915>>65650000
|                       |                          |           <<06915>>65655000
| FUNCTIONAL RETURN     | STATUS                   |           <<06915>>65660000
|  no. of sectors in    |  no errors      -  0     |           <<06915>>65665000
|  an extent of a spool |  baddb          -  -12   |           <<06915>>65670000
|  file.                |                          |           <<06915>>65675000
|                       |                          |           <<06915>>65680000
+--------------------------------------------------+           <<06915>>65685000
END OF COMMENT;                                                <<06915>>65690000
                                                               <<06915>>65695000
INTEGER PROCEDURE NRJESPOOLSECTORS;                            <<06915>>65700000
   OPTION PRIVILEGED, UNCALLABLE;                              <<U7867>>65705000
                                                               <<06915>>65710000
<<--------------- LOCAL VARAIBLES -------------------->>       <<06915>>65715000
                                                               <<06915>>65720000
BEGIN                                                          <<06915>>65725000
                                                               <<06915>>65730000
EQUATE  NUMPARMS     = 0,                                      <<06915>>65735000
        QMARKERLEN   = 4,                                      <<06915>>65740000
        MARKERNPARMS = NUMPARMS + QMARKERLEN;                  <<06915>>65745000
        << Maximum DB relative address of a reference >>       <<06915>>65750000
        << parameter is one word below the location   >>       <<06915>>65755000
        << which contains address/value of 1st parm.  >>       <<06915>>65760000
                                                               <<06915>>65765000
INTEGER XREG = X;                                              <<06915>>65770000
                                                               <<06915>>65775000
INTEGER QMINUSPARMS = Q - MARKERNPARMS;                        <<06915>>65780000
                                                               <<06915>>65785000
EQUATE SPOOLSECTORSPEREXTENT = %1104;                          <<06915>>65790000
                                                               <<06915>>65795000
                                                               <<06915>>65800000
INTRINSIC QUIT, ARITRAP;                                       <<06915>>65805000
                                                               <<06915>>65810000
<<---------------------- EXIT ------------------------>>       <<06915>>65815000
<< Reset critical.  Record reason for return.  Return >>       <<06915>>65820000
<< from procedure or abort.                           >>       <<06915>>65825000
<<---------------------------------------------------->>       <<06915>>65830000
SUBROUTINE EXIT( REASON );                                     <<06915>>65835000
VALUE REASON; INTEGER REASON;                                  <<06915>>65840000
BEGIN                                                          <<06915>>65845000
                                                               <<06915>>65850000
ARITRAP(TRUE);                                                 <<06915>>65855000
                                                               <<06915>>65860000
IF ( REASON = BADDB ) THEN                                     <<06915>>65865000
  QUIT( REASON );                                              <<06915>>65870000
                                                               <<06915>>65875000
ASSEMBLE( EXIT NUMPARMS );                                     <<06915>>65880000
                                                               <<06915>>65885000
END; << SUBROUTINE EXIT >>                                     <<06915>>65890000
                                                               <<06915>>65895000
<<-------------------- INITIAL ----------------------->>       <<06915>>65900000
<< Quit if called in split stack mode.                >>       <<06915>>65905000
<<---------------------------------------------------->>       <<06915>>65910000
SUBROUTINE INITIAL;                                            <<06915>>65915000
BEGIN                                                          <<06915>>65920000
                                                               <<06915>>65925000
ARITRAP(FALSE);                                                <<06915>>65930000
                                                               <<06915>>65935000
IF NOT DB'AT'STACK THEN EXIT(BADDB);                           <<06915>>65940000
                                                               <<06915>>65945000
END; << SUBROUTINE INITIAL >>                                  <<06915>>65950000
                                                               <<06915>>65955000
<<--------------- NRJESPOOLSECTORS ------------------->>       <<06915>>65960000
                                                               <<06915>>65965000
                                                               <<06915>>65970000
<< 1. >>                                                       <<06915>>65975000
INITIAL;                                                       <<06915>>65980000
                                                               <<06915>>65985000
<< 2. >>                                                       <<06915>>65990000
NRJESPOOLSECTORS := ABSOLUTE( SPOOLSECTORSPEREXTENT );         <<06915>>65995000
                                                               <<06915>>66000000
EXIT(OK);                                                      <<06915>>66005000
                                                               <<06915>>66010000
END; << PROCEDURE NRJESPOOLSIZE >>                             <<06915>>66015000
$PAGE "GLOBAL SYMBOL TABLE"                                    <<06915>>66020000
$PAGE                                                          <<06915>>66025000
$CONTROL SEGMENT=MAIN                                          <<06915>>66030000
END.    << SPOOLCOMS (MODULE 80) >>                            <<06915>>66035000
