$CONTROL MAP,CODE,USLINIT                                               00010000
<< MESSAGE -- MODULDE 59 >>                                             00012000
<< HP32002C MPE SOURCE C.00.00 >>                                       00014000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00016000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00018000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00020000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00022000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00024000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00026000
$CONTROL SEGMENT=MESSAGE,MAIN=MESSAGE                                   00028000
BEGIN                                                                   00030000
COMMENT TABLE STRUCTURES TO SUPPORT NON-$STDLIST MESSAGES      <<02802>>00032000
                                                               <<02802>>00034000
MESSAGE BUFFERS DST - POINTED TO BY SYSGLOB %113               <<02802>>00036000
<<*****************************************************>>      <<02802>>00038000
<< WORD | DESCRIPTION                                  >>      <<02802>>00040000
<<*****************************************************>>      <<02802>>00042000
<< 0    | NUMBER OF BUFFERS IN THIS DST                >>      <<02802>>00044000
<< 1    | LENGTH OF BUFFERS IN THIS DST (128 CURRENTLY)>>      <<02802>>00046000
<< 2    | NEXT AVAILABLE BUFFER PTR - DST RELATIVE     >>      <<02802>>00048000
<< 3    | TAIL AVAILABLE BUFFER PTR - DST RELATIVE     >>      <<02802>>00050000
<< 4-N  | # OF BUFFERS * LENGTH OF BUFFER "BUFFER" AREA>>      <<02802>>00052000
<<      | WORD "0" OF EACH BUFFER IS AVAIL BUFFER LINK >>      <<02802>>00054000
<<*****************************************************>>      <<02802>>00056000
                                                               <<02802>>00058000
BUFFER IMPEDED QUEUE (BY PIN) - POINTED TO BY SYSGLOB %62      <<02802>>00060000
                                                               <<02802>>00062000
BASIC IPC (SENDMSG) MESSAGE FORMAT                             <<02802>>00064000
<<*****************************************************>>      <<02802>>00066000
<< WORD | DESCRIPTION                                  >>      <<02802>>00068000
<<*****************************************************>>      <<02802>>00070000
<< 0    | INTEGER "2" - MSG TYPE 2 TO IOMESSAGEPROC    >>      <<02802>>00072000
<< 1    | IOQ INDEX OF MESSAGE ATTACHIO TO TERMINAL    >>      <<02802>>00074000
<< 2    | MESSAGE BUFFER DST OFFSET OF BUFFER USED     >>      <<02802>>00076000
<< 3    | NOT USED, CURRENTLY "0"                      >>      <<02802>>00078000
<<*****************************************************>>      <<02802>>00080000
                                                               <<02802>>00082000
;                                                              <<02802>>00084000
                                                                        00086000
EQUATE                                                                  00088000
   PCBSIZE = 16,                                                        00090000
   PCBB    = 3,                                                         00092000
   CPCB    = 4,                                                         00094000
   QI      = 5,                                                         00096000
                                                                        00098000
   MSGBASE       = %1371,                                               00100000
   MSGSIR        = %24,                                                 00102000
   FISIR         = 37,                                         <<00820>>00104000
   SYSDISC       = 1,                                                   00106000
   SYSUP         = %1073,                                      <<01398>>00108000
   CONSOLECELL   = %1074,                                               00110000
   SYSDB         = 512,                                        <<00820>>00112000
   CLOADID       = SYSDB + %75,                                <<00820>>00114000
                                                               <<02802>>00116000
<< IF NUM'MSG'BUFS IS CHANGED, MUST ALSO CHANGE IN IOMSGPROC >><<02802>>00118000
   NUM'MSG'BUFS  =16,  <<NUMBER OF BUFFERS FOR MSG SYSTEM>>    <<02802>>00120000
   PCB8          = 8,  << PCB WORD 8 (NIMP) >>                 <<02802>>00122000
   SBUFDSTN      = %10,                                                 00124000
   SBUFSIZEW     = 128,                                                 00126000
   SBUFSIZE      = 256,                                                 00128000
   SBUFSIZEWM1   = SBUFSIZEW -1;                                        00130000
                                                                        00132000
DEFINE                                                                  00134000
   DISABLE = ASSEMBLE( SED 0) #,                                        00136000
   ENABLE  = ASSEMBLE( SED 1) #,                                        00138000
   PDISABLE= ASSEMBLE(PSDB)#,                                  <<02802>>00140000
   PENABLE = ASSEMBLE(PSEB)#,                                  <<02802>>00142000
   NIMPPIN = (8:8)#,    << NIMP FIELD IN WORD 8 OF PCB >>      <<02802>>00144000
                                                               <<02802>>00146000
   IOMSGQUEUE = ABSOLUTE(%1062)#, <<IMPEDED LIST HEAD FOR MSG>><<02802>>00148000
   IOMSGDST   = ABSOLUTE(%1113)#, <<DST FOR MESSAGE BUFFERS  >><<02802>>00150000
                                                               <<02802>>00152000
   MYPIN = ((ABSOLUTE(CPCB) -ABSOLUTE(PCBB))/ PCBSIZE)#,                00154000
   SYSPROC = LOGICAL(ABSOLUTE(ABSOLUTE(CPCB) +9).(6:1))#;               00156000
                                                                        00158000
<< Message layout Equates.  See also, SECTPERBLKD, below. >>   <<04362>>00160000
EQUATE                                                                  00162000
   CCG           = 0,                                                   00164000
   CCL           = 1,                                                   00166000
   CCE           = 2,                                                   00168000
                                                                        00170000
   HEADERSIZE    = 2,                                          <<00711>>00172000
   MAXNOSETS     = 62,                                         <<00711>>00174000
   MSGDIRSIZE    = HEADERSIZE + MAXNOSETS*2 + 2 <<WORK SPACE>>,<<00711>>00176000
   MAXSETNOCELL  = 0,                                          <<00711>>00178000
   MAXRECELL     = 1,                                          <<00711>>00180000
   CURRENTRECELL = MSGDIRSIZE - 1,                             <<00711>>00182000
   RECSIZE           = 40,                                              00184000
   RECSIZEB          = RECSIZE*2,                                       00186000
   RECSIZEM1         = RECSIZE -1,                                      00188000
   BUFFSIZE          = RECSIZE -4,                                      00190000
   BUFFSIZEM1        = BUFFSIZE -1,                                     00192000
   BUFFSIZEB         = BUFFSIZE*2,                                      00194000
   BLKFACTOR         = 16,                                              00196000
   PHYSBLK           = 16*40,                                           00198000
   SECTORPERBLK      = PHYSBLK/128,                                     00200000
                                                                        00202000
   ENDOFEQUATES      = 0;                                               00204000
                                                               <<04362>>00206000
<< Sectors per block DEFINEs used for Double arithmetic  >>    <<04362>>00208000
<< in READCAT.  See SECTORPERBLK equate, above.          >>    <<04362>>00210000
   DEFINE                                                      <<04362>>00212000
      SECTPERBLKD     = 5D #;                                  <<04362>>00214000
                                                               <<04362>>00216000
                                                                        00218000
INTEGER                                                                 00220000
   STATUS = Q-1,                                                        00222000
   S0 =S-0,                                                             00224000
   S6 = S-6,                                                            00226000
   X = X;                                                               00228000
                                                                        00230000
BYTE POINTER BPS0 = S-0;                                                00232000
POINTER PS0 = S-0;                                                      00234000
DOUBLE POINTER DPS0 = S-0;                                              00236000
                                                                        00238000
DEFINE                                                                  00240000
   MSGDSTN       = ABSOLUTE(MSGBASE+2)#,                                00242000
                                                                        00244000
   CONDCODE      = STATUS.(6:2)#,                                       00246000
   CCGRETN       = BEGIN                                                00248000
                      CONDCODE := CCG;                                  00250000
                      GO OUTL;                                          00252000
                   END#,                                                00254000
   CCLRETN       = BEGIN                                                00256000
                      CONDCODE := CCL;                                  00258000
                      GO OUTL;                                          00260000
                   END#,                                                00262000
   DEF'MOVEFROMDSEG =                                                   00264000
      MOVEFROMDSEG(TARGET,DSTN,OFFSET,COUNT);                           00266000
         VALUE TARGET,DSTN,OFFSET,COUNT;                                00268000
         LOGICAL TARGET,DSTN,OFFSET,COUNT;                              00270000
      BEGIN                                                             00272000
         X := TOS; << SAVE RETURN ADDRESS >>                            00274000
         ASSEMBLE(MFDS 0);                                              00276000
         TOS := X; << RESTORE RETURN ADDRESS >>                         00278000
      END #,                                                            00280000
                                                                        00282000
   DEF'MOVETODSEG =                                                     00284000
      MOVETODSEG(DSTN,OFFSET,SOURCE,COUNT);                             00286000
         VALUE DSTN,OFFSET,SOURCE,COUNT;                                00288000
         LOGICAL DSTN,OFFSET,SOURCE,COUNT;                              00290000
      BEGIN                                                             00292000
         X := TOS;                                                      00294000
         ASSEMBLE(MTDS 0);                                              00296000
         TOS := X;                                                      00298000
      END #,                                                            00300000
                                                                        00302000
                                                                        00304000
   DEF'PXGLOB =                                                         00306000
      PXGLOB(INDEX);                                                    00308000
         VALUE INDEX;                                                   00310000
         INTEGER INDEX;                                                 00312000
      COMMENT     *** WORKS ONLY IF DB AT STACK *** ;                   00314000
      BEGIN                                                             00316000
                                                                        00318000
      ASSEMBLE(                                                         00320000
      PSHR %40;     << DL >>                                            00322000
      LDXN 1;       << PCBX GLOBE PTR 1 BELOW DL >>                     00324000
      SUBM S-0,I,X; << OFFSET TO PXGLOB >>                              00326000
      STAX,ADBX;    << X:= OFFSET + INDEX >>                            00328000
      LOAD DB+0,X;  << GET VALUE >>                                     00330000
      STOR S-3;);   << PUT IN RETURN VALUE >>                           00332000
      END << PXGLOB >>   #;                                             00334000
                                                                        00336000
<< END GLOBAL DECLS >>                                                  00338000
                                                                        00340000
        << HERE ARE THE PARM MASK DEFINITIONS >>                        00342000
        << FOR GENMSG & FORMSG PMASKS         >>                        00344000
LOGICAL                                                                 00346000
   PMASK = Q-4;                                                         00348000
POINTER PCB=3;                                                 <<00933>>00350000
DEFINE PCB'ACTORG=8).(4:2#,    <<TYPE OF PCB ACTIVATION>>      <<01549>>00352000
       PCB'REPLYDONE=3#;                                       <<00933>>00354000
                                                                        00356000
DEFINE                                                                  00358000
   PSETNO  = ( 3:1) #,                                                  00360000
   PMSGNO  = ( 4:1) #,                                                  00362000
   PPMASK  = ( 5:1) #,                                                  00364000
   PDEST   = (11:1) #,                                                  00366000
   PREPLY  = (12:1) #,                                                  00368000
   POFFSET = (13:1) #,                                                  00370000
   PDST    = (14:1) #,                                                  00372000
   PCONTROL = (15:1) #;                                                 00374000
                                                                        00376000
$INCLUDE INCLRIT                                               <<04882>>00378000
<< APL FUNNY TERMINAL STUFF >>                                          00382000
DEFINE FUNNYTERM = (2:2)#;                                              00384000
                                                               <<01646>>00386000
EQUATE GENERALSET=1;                                           <<04882>>00388000
EQUATE REPLYWOKEN=293;                                        <<<04882>>00390000
EQUATE REPLYIMPEDED=294;                                      <<<04882>>00392000
EQUATE QUEUEFULL=295;                                         <<<04882>>00394000
EQUATE TELLUSER'NOROOM =296;                                  <<<04882>>00396000
EQUATE TELLOP'QUEUED'USER = 297;                               <<04882>>00398000
<< JMAT DEFINITIONS >>                                         <<01646>>00400000
                                                               <<01646>>00402000
EQUATE                                                                  00404000
   JMATX        = 3,                                                    00406000
   JMATENTRYSIZE= 26,                                                   00408000
   JMATDST      = %31;                                                  00410000
                                                               <<01646>>00412000
DEFINE                                                         <<01646>>00414000
   JMAT'OUTDEV = 18).(8:8#;  << OUTPUT DEVICE FROM JMAT >>     <<01646>>00416000
                                                                        00418000
<< FILE SYSTEM DEFINES >>                                      <<00820>>00420000
DEFINE                                                         <<00820>>00422000
   << FILE LABEL DEFINITIONS >>                                <<00820>>00424000
   FLSTATUS    =FLAB(28).(14:2)#,<< WRITE/READ STATUS >>       <<00820>>00426000
   FLCLID      =FLAB(35)#,       << COLD LOAD ID >>            <<00820>>00428000
   FLFCBVECT   =FLAB(27)#,       << FCB VECTOR >>              <<00820>>00430000
                                                               <<00820>>00432000
   << FCB DEFINITIONS >>                                       <<00820>>00434000
   FCBLKST     =FCB(4).(0:2)#;   << PREVIOUS LOCK STATE >>     <<00820>>00436000
                                                                        00438000
<< ASSOCIATION TABLE DEFINITIONS >>                            <<01646>>00440000
                                                               <<01646>>00442000
EQUATE                                                         <<01646>>00444000
   ASS'SIR = 24,       << SIR # FOR ASSOCIATION TABLE >>       <<01646>>00446000
   ASS'DST = 34,       << DST # FOR ASSOCIATION TABLE >>       <<01646>>00448000
   ASS'ENTRYSIZE = 7;  << SIZE OF ONE ENTRY IN TABLE  >>       <<01646>>00450000
                                                               <<01646>>00452000
DEFINE                                                         <<01646>>00454000
   ASS'JMAT = 0).(8:8#;      << JMAT INDEX >>                  <<01646>>00456000
                                                               <<01646>>00458000
                                                                        00460000
<< EXTERNAL DECLARATIONS >>                                             00462000
                                                                        00464000
PROCEDURE APLTRANSLATEOUT(MESSAGE,LENGTH,TRANSTYPE);                    00466000
   VALUE LENGTH,TRANSTYPE;INTEGER LENGTH,TRANSTYPE;                     00468000
   BYTE ARRAY MESSAGE;OPTION EXTERNAL;                                  00470000
                                                                        00472000
INTRINSIC ASCII,BINARY,DASCII,PRINT,FWRITE,FCHECK,FOPEN,                00474000
   FGETINFO,FREADLABEL,FCLOSE;                                          00476000
                                                                        00478000
PROCEDURE AWAKE(PIN,AF,WF);VALUE PIN,AF,WF;                             00480000
   INTEGER PIN,AF,WF;OPTION EXTERNAL;                                   00482000
                                                                        00484000
DOUBLE PROCEDURE ATTACHIO(A,B,C,D,E,F,G,H,I);                           00486000
   VALUE A,B,C,D,E,F,G,H,I;                                             00488000
   LOGICAL A,B,C,D,E,F,G,H,I;                                           00490000
   OPTION EXTERNAL;                                                     00492000
                                                                        00494000
PROCEDURE ERRORON; OPTION EXTERNAL;                                     00496000
                                                               <<01998>>00498000
   LOGICAL PROCEDURE JOBSESSIONMAIN;                           <<01998>>00500000
   OPTION UNCALLABLE,EXTERNAL;                                 <<01998>>00502000
                                                                        00504000
PROCEDURE ERROREXIT(INTRINEXIT,ERRWORD,PARAM);                          00506000
   VALUE INTRINEXIT,ERRWORD,PARAM;                                      00508000
   LOGICAL INTRINEXIT,ERRWORD,PARAM;                                    00510000
   OPTION EXTERNAL;                                                     00512000
                                                                        00514000
INTEGER PROCEDURE EXCHANGEDB(DSTX);                                     00516000
   VALUE DSTX; LOGICAL DSTX; OPTION EXTERNAL;                           00518000
PROCEDURE FGETCB (NEWVECTOR,DST,CB,VECTOR,FLAGS,S1,O1,S2,O2);  <<01391>>00520000
   VALUE NEWVECTOR,DST,CB,VECTOR,FLAGS,S1,O1,S2,O2;            <<01391>>00522000
   INTEGER NEWVECTOR,DST,VECTOR,S1,O1,S2,O2;                   <<01391>>00524000
   INTEGER POINTER CB;                                         <<00820>>00526000
   LOGICAL FLAGS;                                              <<00820>>00528000
   OPTION VARIABLE,EXTERNAL;                                   <<01391>>00530000
                                                               <<00820>>00532000
INTEGER PROCEDURE FLABIO (LDEV,SECTOR,FUNC,FLAB);              <<00820>>00534000
   VALUE LDEV,SECTOR,FUNC;                                     <<00820>>00536000
   INTEGER LDEV,FUNC;                                          <<00820>>00538000
   DOUBLE SECTOR;                                              <<00820>>00540000
   INTEGER ARRAY FLAB;                                         <<00820>>00542000
   OPTION PRIVILEGED,UNCALLABLE,EXTERNAL;                      <<00820>>00544000
                                                               <<00820>>00546000
PROCEDURE FRELCB (DST,VECTOR,FLAGS);                           <<00820>>00548000
   VALUE DST,VECTOR,FLAGS;                                     <<00820>>00550000
   INTEGER DST,VECTOR;                                         <<00820>>00552000
   LOGICAL FLAGS;                                              <<00820>>00554000
   OPTION PRIVILEGED,UNCALLABLE,EXTERNAL;                      <<00820>>00556000
                                                               <<00820>>00558000
                                                                        00560000
INTEGER PROCEDURE GETDATASEG(MEMSIZE,VDSIZE);                           00562000
   VALUE MEMSIZE,VDSIZE;                                                00564000
   INTEGER MEMSIZE,VDSIZE;                                              00566000
   OPTION EXTERNAL;                                                     00568000
                                                                        00570000
INTEGER PROCEDURE GETSIR(SIRNUM);                                       00572000
   VALUE SIRNUM; LOGICAL SIRNUM; OPTION EXTERNAL;                       00574000
                                                                        00576000
INTEGER PROCEDURE GETSYSBUF(NUM,IFLAG);VALUE NUM,IFLAG;                 00578000
   INTEGER NUM;LOGICAL IFLAG;OPTION EXTERNAL;                           00580000
                                                                        00582000
PROCEDURE IMPEDE(PINX);                                                 00584000
   VALUE PINX; INTEGER PINX; OPTION EXTERNAL;                           00586000
                                                                        00588000
   PROCEDURE LOG15(I,J,K,L);                                   <<KS.01>>00590000
   VALUE I,J,K,L;                                              <<KS.01>>00592000
   LOGICAL I,J,K,L;                                            <<KS.01>>00594000
   OPTION EXTERNAL;                                            <<KS.01>>00596000
                                                               <<04882>>00598000
                                                               <<00820>>00600000
PROCEDURE RELDATASEG(DSTNUM);                                  <<00820>>00602000
   VALUE DSTNUM;                                               <<00820>>00604000
   INTEGER DSTNUM;                                             <<00820>>00606000
   OPTION EXTERNAL;                                            <<00820>>00608000
                                                               <<00820>>00610000
INTEGER PROCEDURE RELSIR(SIRNUM,A);                                     00612000
   VALUE SIRNUM,A; LOGICAL SIRNUM,A; OPTION EXTERNAL;                   00614000
                                                                        00616000
PROCEDURE SENDMSG(DESTPIN,DESTPORT,MSGLENGTH,FLAGS);           <<02802>>00618000
VALUE DESTPIN,DESTPORT,MSGLENGTH,FLAGS;                        <<02802>>00620000
INTEGER DESTPIN,DESTPORT,MSGLENGTH;                            <<02802>>00622000
LOGICAL FLAGS;                                                 <<02802>>00624000
OPTION EXTERNAL;                                               <<02802>>00626000
                                                               <<02802>>00628000
INTEGER PROCEDURE SETCRITICAL;                                 <<02802>>00630000
OPTION EXTERNAL;                                               <<02802>>00632000
                                                               <<02802>>00634000
PROCEDURE RESETCRITICAL(CRIT);                                 <<02802>>00636000
VALUE CRIT;                                                    <<02802>>00638000
INTEGER CRIT;                                                  <<02802>>00640000
OPTION EXTERNAL;                                               <<02802>>00642000
                                                               <<02802>>00644000
PROCEDURE SUDDENDEATH(A);VALUE A;INTEGER A;OPTION EXTERNAL;             00646000
                                                                        00648000
PROCEDURE WAIT(A,B);                                                    00650000
   VALUE A,B; LOGICAL A,B; OPTION EXTERNAL;                             00652000
                                                                        00654000
<< FORWARD DECLARATIONS >>                                              00656000
                                                                        00658000
INTEGER PROCEDURE CONSPREFIX(CONSREPLY,BUFF');                          00660000
   VALUE CONSREPLY;                                                     00662000
   LOGICAL CONSREPLY;                                                   00664000
   ARRAY BUFF';                                                         00666000
   OPTION FORWARD;                                                      00668000
                                                                        00670000
INTEGER PROCEDURE GENMSG(A,B,C,D,E,F,G,H,I,J,K,L,M);                    00672000
   VALUE A,B,C,D,E,F,G,H,I,J,K,L,M;INTEGER A,B,I,L;                     00674000
   LOGICAL C,D,E,F,G,H,J,K,M;OPTION VARIABLE,FORWARD;                   00676000
                                                                        00678000
<< PROCEDURES >>                                                        00680000
LOGICAL PROCEDURE PUT'IN'RIT'QUEUE(PINX);                      <<04882>>00682000
VALUE PINX;                                                    <<04882>>00684000
INTEGER PINX;                                                  <<04882>>00686000
OPTION PRIVILEGED,UNCALLABLE;                                  <<04882>>00688000
<< This procedure is designed to queue entries that were  >>   <<04882>>00690000
<< unable to be put in the Reply Information Table because>>   <<04882>>00692000
<< it was full.  If there is room in the queue then the   >>   <<04882>>00694000
<< PIN for that process will be placed in the queue.  If  >>   <<04882>>00696000
<< there is no room then the PIN will not be put in the   >>   <<04882>>00698000
<< queue and messages will be sent to the console and User>>   <<04882>>00700000
                                                               <<04882>>00702000
 BEGIN                                                         <<04882>>00704000
    INTEGER ARRAY RITABLE(*) = DB+0;                           <<04882>>00706000
   INTEGER NUMQUEUED;                                          <<04882>>00708000
                                                               <<04882>>00710000
PUT'IN'RIT'QUEUE := TRUE;                                      <<04882>>00712000
IF RITABLE(QUEUED'ENTRIES) <  MAX'QUEUED'ENTRIES THEN          <<04882>>00714000
   BEGIN                                                       <<04882>>00716000
     RITABLE(RITABLE(LIQ)) := PINX;                            <<04882>>00718000
     RITABLE(LIQ) := RITABLE(LIQ) + 1;                         <<04882>>00720000
     RITABLE(QUEUED'ENTRIES) := RITABLE(QUEUED'ENTRIES) + 1;   <<04882>>00722000
     NUMQUEUED := RITABLE(QUEUED'ENTRIES);                     <<04882>>00724000
     << This is decremented in REM'QUEUED'ENTRY           >>   <<04882>>00726000
     EXCHANGEDB(0);                                            <<04882>>00728000
     GENMSG(GENERALSET,REPLYIMPEDED); << TELL USER HE IS QUEUED<<04882>>00730000
     GENMSG(GENERALSET,TELLOP'QUEUED'USER,%10000,NUMQUEUED,    <<04882>>00732000
           ,,,,0);                                             <<04882>>00734000
   END                                                         <<04882>>00736000
   ELSE BEGIN << NO ROOM IN QUEUE >>                           <<04882>>00738000
          PUT'IN'RIT'QUEUE := FALSE;                           <<04882>>00740000
          EXCHANGEDB(0);                                       <<04882>>00742000
          GENMSG(GENERALSET,QUEUEFULL,,,,,,,0);                <<04882>>00744000
          GENMSG(GENERALSET,TELLUSER'NOROOM)                   <<04882>>00746000
          END;                                                 <<04882>>00748000
END; << PUT'IN'RIT'QUEUE >>                                    <<04882>>00750000
                                                                        00752000
                                                                        00754000
LOGICAL PROCEDURE PUTRITENTRY(PINX,DST,OFFSET,REPLY,LEN,BUFF');<<04882>>00756000
   VALUE PINX,DST,OFFSET,REPLY,LEN;                                     00758000
   INTEGER PINX,DST,OFFSET,REPLY,LEN;                                   00760000
   ARRAY BUFF';                                                         00762000
   OPTION INTERNAL;                                                     00764000
COMMENT                                                                 00766000
   PLACES ENTRY IN RIT. SEARCHES THROUGH RIT & USES FIRST               00768000
   AVAILABLE ENTRY. IF NONE AVAILABLE, THIS PROCESS IS                  00770000
   IS PUT INTO A QUEUE BY A CALL TO PUT'IN'RIT'QUEUE AND THEN  <<04882>>00772000
   IT IS IMPEDED UNTIL A REPLY CALLS REM'QUEUED'ENTRY WHICH    <<04882>>00774000
   WILL WAKE THE PROCESS THATS BEEN QUEUED THE LONGEST         <<04882>>00776000
   THE AWOKEN PROCESS WILL THEN ATTEMPT TO ENTER THE RIT TABLE <<04882>>00778000
;                                                                       00780000
BEGIN                                                                   00782000
INTEGER                                                                 00784000
   INDEX;                                                               00786000
                                                                        00788000
LOGICAL SIRN;                                                           00790000
LOGICAL NOPROBLEM;                                             <<04882>>00792000
INTEGER ARRAY RITABLE(*) = DB+0;                                        00794000
                                                                        00796000
SUBROUTINE DEF'MOVETODSEG;                                              00798000
                                                                        00800000
<< FILL IN RITDESCRIPTOR >>                                             00802000
   SIRN := 0;                                                  <<04811>>00804000
   BUFF' := PINX;                                                       00806000
   IF DST <> 0 THEN BUFF'(1) := DST                                     00808000
   ELSE                                                                 00810000
   BEGIN << COMPUTE SEG. REL. ADR. OF OFFSET >>                         00812000
      DISABLE;                                                          00814000
      TOS := ABSOLUTE( ABSOLUTE( QI ) -5);                              00816000
      TOS := ABSOLUTE(X := X-4) +1;                                     00818000
      ASSEMBLE( LSEA );                                                 00820000
      INDEX := TOS;                                                     00822000
      DDEL;                                                             00824000
      BUFF'(1) := ABSOLUTE(X:= X-7); << STACK DST # >>                  00826000
      ENABLE;                                                           00828000
      OFFSET := OFFSET+ INDEX;                                          00830000
   END;                                                                 00832000
   BUFF'(2) := OFFSET;                                                  00834000
   BUFF'(3) := REPLY;                                                   00836000
   BUFF'(6) := 0;  << CONTROL WORD. (VESTIGIAL) >>                      00838000
   BUFF'(RIT'MSGLEN) := IF LEN > RIT'MSGSIZE THEN RIT'MSGSIZE  <<04882>>00840000
      ELSE LEN;                                                         00842000
                                                                        00844000
AGAIN:                                                                  00846000
NOPROBLEM := TRUE; << ASSUME IT WILL WORK >>                   <<04882>>00848000
IF LOGICAL(ABSOLUTE(ABSOLUTE(CPCB)+9).(11:1))                  <<04882>>00850000
   THEN BEGIN                                                  <<04882>>00852000
        << SOFTKILL BIT IS SET ON >>                           <<04882>>00854000
        NOPROBLEM := FALSE;                                    <<04882>>00856000
        GO AROUND;                                             <<04882>>00858000
        END;                                                   <<04882>>00860000
EXCHANGEDB(RIT'DST);                                           <<04882>>00862000
SIRN := GETSIR(RIT'SIR);                                       <<04882>>00864000
IF RITABLE = RITABLE(RIT'HEAD'MAXENT) THEN << TABLE FULL >>    <<04882>>00866000
BEGIN                                                                   00868000
   NOPROBLEM := PUT'IN'RIT'QUEUE(PINX);                        <<04882>>00870000
   RELSIR(RIT'SIR,SIRN);                                       <<04882>>00872000
   IF NOPROBLEM THEN                                           <<04882>>00874000
      BEGIN                                                    <<04882>>00876000
        WAIT(%40,0);                                           <<04882>>00878000
        GENMSG(GENERALSET,REPLYWOKEN);                         <<04882>>00880000
        GO AGAIN;  << TRY AGAIN >>                             <<04882>>00882000
        END;                                                   <<04882>>00884000
END;                                                                    00886000
AROUND:                                                        <<04882>>00888000
IF NOPROBLEM                                                   <<04882>>00890000
   THEN BEGIN                                                  <<04882>>00892000
          RITABLE := RITABLE + 1;                              <<04882>>00894000
          INDEX := RIT'HEADSIZE - RIT'SIZE;                    <<04882>>00896000
                                                               <<04882>>00898000
          DO INDEX := INDEX + RIT'SIZE UNTIL RITABLE(INDEX)=0; <<04882>>00900000
          << FOUND EMPTY ENTRY >>                              <<04882>>00902000
          EXCHANGEDB(0);                                       <<04882>>00904000
          MOVETODSEG(RIT'DST,INDEX,@BUFF',RIT'SIZE);           <<04882>>00906000
          RELSIR(RIT'SIR,SIRN);                                <<04811>>00908000
          END                                                  <<04882>>00912000
       ELSE EXCHANGEDB(0);                                     <<04882>>00914000
       PUTRITENTRY := NOPROBLEM;                               <<04882>>00916000
                                                                        00920000
END; << PUTRITENTRY >>                                                  00922000
$TITLE "LENBUF - FINDS LENGTH, CRLF & CONTINUED"                        00924000
PROCEDURE LENBUF(BUFF,LEN,CRLF,RECNO);                                  00926000
   BYTE ARRAY BUFF;                                                     00928000
   INTEGER LEN;                                                <<02340>>00930000
   DOUBLE RECNO;                                               <<02340>>00932000
   LOGICAL CRLF;                                                        00934000
   OPTION INTERNAL;                                                     00936000
BEGIN                                                                   00938000
                                                                        00940000
                                                                        00942000
INTEGER SUBROUTINE DEBLANK(BUFF,WIDTH);                                 00944000
   VALUE WIDTH; INTEGER WIDTH;                                          00946000
   BYTE ARRAY BUFF;                                                     00948000
COMMENT                                                                 00950000
   DEBLANKS ON RIGHT                                                    00952000
;                                                                       00954000
BEGIN                                                                   00956000
                                                                        00958000
X := WIDTH -1;                                                          00960000
IF BUFF(X) <> " " THEN DEBLANK := WIDTH                                 00962000
ELSE                                                                    00964000
BEGIN                                                                   00966000
   TOS := @BUFF(X);                                                     00968000
   ASSEMBLE(DUP,DECA);                                                  00970000
   TOS := -X;                                                           00972000
   ASSEMBLE(CMPB 0);                                                    00974000
   S6 := -TOS;  << DEBLANK := -TOS >>                                   00976000
   DDEL;                                                                00978000
END;                                                                    00980000
                                                                        00982000
END; << DEBLANK >>                                                      00984000
                                                                        00986000
   << FIND LENGTH OF MSG & IF CONTINUED ON NEXT REC >>                  00988000
CRLF := 0;                                                              00990000
LEN := DEBLANK(BUFF,BUFFSIZEB);                                         00992000
IF BUFF(X:=LEN-1) = "&" OR BUFF(X) = "%" THEN                           00994000
BEGIN                                                                   00996000
   IF BUFF(X) = "&" THEN CRLF := %320;                                  00998000
   RECNO := RECNO + 1D; << CONTINUED ON NEXT RECORD >>         <<02340>>01000000
      << NOW FIND LENGTH WITHOUT % OR & >>                              01002000
   LEN := DEBLANK(BUFF,LEN -1);                                         01004000
END                                                                     01006000
ELSE  RECNO := 0D;  << NOT CONTINUED >>                        <<02340>>01008000
                                                                        01010000
END; <<  LENBUF >>                                                      01012000
$TITLE "READCAT"                                                        01014000
PROCEDURE READCAT( RECNO, BUFF', RECNOLO, RECNOHI );           <<04707>>01016000
   VALUE RECNO, RECNOLO, RECNOHI;                              <<04707>>01018000
   DOUBLE RECNO, RECNOLO, RECNOHI;                             <<04707>>01020000
   ARRAY BUFF';                                                         01022000
   OPTION UNCALLABLE;                                                   01024000
                                                                        01026000
COMMENT                                                                 01028000
   READS A RECORD FROM THE MESSAGE CATALOG.                             01030000
   RECNO - RECORD NUMBER. NO CHECKING DONE ON THIS NO.                  01032000
   BUFF' - BUFFER AS LARGE AS RECORD SIZE                               01034000
   CCE     EVERYTHING OK.                                               01036000
   CCL     ATTACHIO FAIL.                                               01038000
                                                               <<04707>>01040000
The ATTACHIO call in this procedure is optimized for the MPE   <<04707>>01042000
Message facility.  This is indicated by the special values in  <<04707>>01044000
the Flags parameter.  This special call requires a base sector <<04707>>01046000
address and a number of sectors in extent to be stacked before <<04707>>01048000
the call--thus, RECNOLO and RECNOHI are the limits of the      <<04707>>01050000
search for the message.  When these parameters are zero, there <<04707>>01052000
is no block search specified, and dummy values are given to the<<04707>>01054000
ATTACHIO call.                                                 <<04707>>01056000
                                                               <<04707>>01058000
;                                                                       01060000
BEGIN                                                                   01062000
                                                                        01064000
EQUATE                                                         <<04707>>01066000
   ATFLAGS = %100001;                                          <<04707>>01068000
                                                               <<04707>>01070000
DOUBLE                                                         <<04707>>01072000
   ATRETURN;                                                   <<04707>>01074000
                                                               <<04707>>01076000
INTEGER                                                        <<04707>>01078000
   ATRETSTAT = ATRETURN;                                       <<04707>>01080000
                                                               <<04707>>01082000
INTEGER                                                                 01084000
   CURRENTREC,                                                          01086000
   SECTS'IN'EXT,     << Sectors in extent (for attachio). >>   <<04707>>01088000
   OFFSET = CURRENTREC,                                                 01090000
   RECOFFSET;                                                           01092000
BYTE ARRAY BUFF(*)=BUFF';                                               01094000
<< Variables for message disc address calculations.  >>        <<04362>>01096000
                                                               <<04707>>01098000
DOUBLE TEMPADRD;     << For calculating sector addresses. >>   <<04707>>01100000
INTEGER TEMPADRHI  = TEMPADRD,                                 <<04707>>01102000
        TEMPADRLO  = TEMPADRD + 1;                             <<04707>>01104000
                                                               <<04707>>01106000
DOUBLE BASEADR,      << Base sector address for search.   >>   <<04707>>01108000
       HIGHADR,      << Limit sector address for search.  >>   <<04707>>01110000
       DISCADR;      << Target sector address.            >>   <<04707>>01112000
                                                               <<04707>>01114000
INTEGER  DISCADHI = DISCADR,                                   <<04707>>01116000
         DISCADLO = DISCADR + 1;                               <<04707>>01118000
                                                               <<04707>>01120000
                                                                        01122000
SUBROUTINE DEF'MOVEFROMDSEG;                                            01124000
                                                                        01126000
SUBROUTINE DEF'MOVETODSEG;                                              01128000
                                                                        01130000
DOUBLE SUBROUTINE SECTOR( REC );                               <<04707>>01132000
   VALUE REC;                                                  <<04707>>01134000
   DOUBLE REC;                                                 <<04707>>01136000
BEGIN                                                          <<04707>>01138000
                                                               <<04707>>01140000
<< Calculate a record's disc sector address.  First its   >>   <<04707>>01142000
<< sector offset is calculated (note: "//" is double      >>   <<04707>>01144000
<< divide), and this is added to the SYSGLOB message base.>>   <<04707>>01146000
   OFFSET := INTEGER(                                          <<04707>>01148000
                DOUBLE( REC // LOGICAL(BLKFACTOR) )            <<04707>>01150000
                * SECTPERBLKD                                  <<04707>>01152000
                + SECTPERBLKD           );                     <<04707>>01154000
   TEMPADRHI := INTEGER( ABSOLUTE( MSGBASE ).(8:8) );          <<04707>>01156000
   TEMPADRLO := ABSOLUTE( MSGBASE+1 );                         <<04707>>01158000
   TEMPADRD  := TEMPADRD + DOUBLE( OFFSET );                   <<04707>>01160000
   SECTOR := TEMPADRD;                                         <<04707>>01162000
                                                               <<04707>>01164000
END;                                                           <<04707>>01166000
                                                               <<04707>>01168000
                                                                        01170000
CONDCODE := CCE;                                                        01172000
                                                                        01174000
<< GET CURRENT RECORD, SEE IF RECNO IS IN DSEG >>                       01176000
                                                                        01178000
MOVEFROMDSEG(@CURRENTREC,MSGDSTN,CURRENTRECELL,1);                      01180000
IF (RECNO >= DOUBLE(CURRENTREC)) AND                           <<02340>>01182000
   (RECNO <= DOUBLE(CURRENTREC+BLKFACTOR-1)) THEN              <<02340>>01184000
ELSE << GO GET IT >>                                                    01186000
BEGIN                                                                   01188000
   << OFFSET OF LOG. REC. IN BLOCK >>                          <<02340>>01192000
   RECOFFSET := INTEGER(RECNO MODD LOGICAL(BLKFACTOR));        <<02340>>01194000
   DISCADR := SECTOR( RECNO );                                 <<04707>>01196000
   IF RECNOLO = 0D THEN    << No search block specified. >>    <<04707>>01198000
   BEGIN                                                       <<04707>>01200000
      BASEADR := DISCADR - 1D;                                 <<04707>>01202000
      SECTS'IN'EXT := 2;                                       <<04707>>01204000
   END                                                         <<04707>>01206000
   ELSE                                                        <<04707>>01208000
   BEGIN                   << Calculate search limits.   >>    <<04707>>01210000
      BASEADR := SECTOR( RECNOLO );                            <<04707>>01212000
      SECTS'IN'EXT := INTEGER(SECTOR(RECNOHI)-BASEADR) + 1;    <<04707>>01214000
   END;                                                        <<04707>>01216000
   TOS := BASEADR;   << Stacked parms for ATTACHIO       >>    <<04707>>01218000
   TOS := SECTS'IN'EXT;                                        <<04707>>01220000
   ATRETURN := ATTACHIO( ABSOLUTE(MSGBASE).(0:8), 0, MSGDSTN,  <<04707>>01222000
      MSGDIRSIZE, 0, PHYSBLK,                                  <<04707>>01224000
      DISCADHI, DISCADLO, ATFLAGS );                           <<04707>>01226000
   DDEL; DEL;  << Pop Attachio stacked parms >>                <<04707>>01228000
   IF ATRETSTAT.(8:8) <> 1 THEN CCLRETN;                       <<04707>>01230000
                                                                        01232000
   << UPDATE CURRENT RECORD PTR IN DSEG >>                              01234000
   CURRENTREC := INTEGER(RECNO // LOGICAL(BLKFACTOR))          <<02340>>01236000
                 * BLKFACTOR;                                  <<02340>>01238000
   MOVETODSEG(MSGDSTN,CURRENTRECELL,@CURRENTREC,1);                     01240000
END;                                                                    01242000
                                                                        01244000
   << RECNO IN DSEG. MOVE TO STACK >>                                   01246000
MOVEFROMDSEG(@BUFF',MSGDSTN,INTEGER(RECNO-DOUBLE(CURRENTREC))  <<02340>>01248000
       * RECSIZE + MSGDIRSIZE,BUFFSIZE);                       <<02340>>01250000
                                                                        01252000
                                                                        01254000
OUTL:                                                                   01256000
END; << READCAT >>                                                      01258000
                                                               <<00820>>01260000
$TITLE "SETLOCKSTATUS"                                         <<00820>>01262000
PROCEDURE SETLOCKSTATUS(LABELADDR,PURGEOK);                    <<00820>>01264000
   VALUE LABELADDR,PURGEOK;                                    <<00820>>01266000
   DOUBLE LABELADDR;                                           <<00820>>01268000
   LOGICAL PURGEOK;                                            <<00820>>01270000
   OPTION UNCALLABLE,PRIVILEGED;                               <<00820>>01272000
BEGIN                                                          <<00820>>01274000
COMMENT:                                                       <<00820>>01276000
   THIS PROCEDURE SETS OR CLEARS THE LOCK STATE OF             <<00820>>01278000
   A FILE. IF THE LOCK STATE IS SET, THE FILE CANNOT           <<00820>>01280000
   BE PURGED.                                                  <<00820>>01282000
      PURGEOK:  TRUE --> CLEAR LOCK STATE                      <<00820>>01284000
                FALES --> SET LOCK STATE TO 1                  <<00820>>01286000
   THE 8 HIGH ORDER BITS OF LABELADDR CONTAIN THE LDEV #.      <<00820>>01288000
   THE LOW ORDER 24 BITS CONTAIN THE SECTOR ADDRESS OF THE     <<00820>>01290000
   FILE.                                                       <<00820>>01292000
CONDITION CODE:                                                <<00820>>01294000
   CCE = EVERTYING OK                                          <<00820>>01296000
   CCL = ERROR OCCURED -- LOCK STATE UNCHANGED.                <<00820>>01298000
;                                                              <<00820>>01300000
DEFINE                                                         <<00820>>01302000
   UNLOCKFCB = FRELCB(OURDST'FCB,NEWFCBV,1) #;                 <<00820>>01304000
EQUATE                                                         <<00820>>01306000
   READ  = 0,                                                  <<00820>>01308000
   WRITE = 1;                                                  <<00820>>01310000
INTEGER                                                        <<00820>>01312000
   ERRORCODE,        << ERROR - RETURNED FROM FLABIO >>        <<00820>>01314000
   NEWFCBV,          << RETURNED FROM FGETCB >>                <<00820>>01316000
   SIRN,                                                       <<00820>>01318000
   LDEV,                                                       <<00820>>01320000
   OURDST'FCB,       << RETURNED FROM FGETCB >>                <<00820>>01322000
   DUM        = DB+0,                                          <<00820>>01324000
   LABELADDR1 = LABELADDR;                                     <<00820>>01326000
INTEGER POINTER                                                <<00820>>01328000
   FCB;           << RETURNED FOR FGETCB >>                    <<00820>>01330000
INTEGER ARRAY                                                  <<00820>>01332000
   FLAB(0:127);   << FILE LABEL >>                             <<00820>>01334000
                                                               <<00820>>01336000
SUBROUTINE LOCKFCB;                                            <<00820>>01338000
BEGIN                                                          <<00820>>01340000
   FGETCB(0,0,DUM,FLFCBVECT,1);  <<DB = FCB DST>>              <<00820>>01342000
   @FCB := TOS;                                                <<00820>>01344000
   OURDST'FCB := TOS;                                          <<00820>>01346000
   NEWFCBV := TOS;                                             <<00820>>01348000
END;  << SUBROUTINE LOCKFCB >>                                 <<00820>>01350000
                                                               <<00820>>01352000
CONDCODE := CCE;                                               <<00820>>01354000
LDEV := LABELADDR1.(0:8);                                      <<00820>>01356000
LABELADDR1.(0:8) := 0;  << LABELADDR1 GETS SECTOR ADDR1 >>     <<00820>>01358000
SIRN := GETSIR(FISIR);                                         <<00820>>01360000
ERRORCODE := FLABIO(LDEV,LABELADDR,READ,FLAB);                 <<00820>>01362000
IF ERRORCODE <> 0 THEN CCLRETN;                                <<00820>>01364000
IF FLFCBVECT = 0 OR ABSOLUTE(CLOADID) <> FLCLID THEN           <<00820>>01366000
   BEGIN                                                       <<00820>>01368000
   COMMENT:                                                    <<00820>>01370000
      NO ACCESSORS --> NO FCB.                                 <<00820>>01372000
      SET STATUS IN FILE LABEL.;                               <<00820>>01374000
   IF PURGEOK THEN FLSTATUS := 0                               <<00820>>01376000
   ELSE FLSTATUS := 1;                                         <<00820>>01378000
   ERRORCODE := FLABIO(LDEV,LABELADDR,WRITE,FLAB);             <<00820>>01380000
   IF ERRORCODE <> 0 THEN CCLRETN;                             <<00820>>01382000
   END                                                         <<00820>>01384000
ELSE                                                           <<00820>>01386000
   BEGIN                                                       <<00820>>01388000
   COMMENT:                                                    <<00820>>01390000
      FCB EXISTS. MARK STATUS IN FCB. THIS WILL                <<00820>>01392000
      BE TRANSFERED TO FILE LABEL WHEN THE                     <<00820>>01394000
      FILE IS CLOSED.;                                         <<00820>>01396000
   LOCKFCB;                                                    <<00820>>01398000
   << DB NOW AT FCB >>                                         <<00820>>01400000
   IF PURGEOK THEN FCBLKST := 0                                <<00820>>01402000
   ELSE FCBLKST := 1;                                          <<00820>>01404000
   UNLOCKFCB;                                                  <<00820>>01406000
   END;                                                        <<00820>>01408000
OUTL:                                                          <<00820>>01410000
   RELSIR(FISIR,SIRN);                                         <<00820>>01412000
END; << SETLOCKSTATUS >>                                       <<00820>>01414000
                                                               <<00820>>01416000
                                                               <<00820>>01418000
$TITLE "FINDMSG"                                                        01420000
DOUBLE PROCEDURE FINDMSG(SETNO,MSGNO,BUFF',LEN,CRLF);          <<02340>>01422000
   VALUE SETNO,MSGNO;                                                   01424000
   INTEGER SETNO,MSGNO,LEN;                                             01426000
   ARRAY BUFF';                                                         01428000
   LOGICAL CRLF;                                                        01430000
   OPTION INTERNAL;                                                     01432000
COMMENT                                                                 01434000
   FETCHES ONE LINE OF MESSAGE FROM MSG CATALOG. TRANSFORMS             01436000
   SETNO & MSGNO INTO RECORD NUMBER & CALLS READCAT TO GET              01438000
   MSG.  REC NO. IS CALCULATED BY FINDING STARTING RECORD               01440000
   NUMBER OF FIRST MESSAGE IN DIRECTORY & ADDING IN THE                 01442000
   DIFFERENCE BETWEEN MSGNO & FIRST MSG NO. IN CATALOG                  01444000
   (ALSO IN DIRECTORY). IF THE MSG FOUND IN THE CATALOG                 01446000
   IS NOT THE ONE DESIRED, A BINARY SEARCH IS THEN DONE.                01448000
   BUFF' MUST BE AT LEAST AS LARGE AS RECORD SIZE.                      01450000
PARAMETERS                                                              01452000
   SETNO  = SETNO FROM GENMSG.                                          01454000
   MSGNO  = MSGNO FROM GENMSG.                                          01456000
   BUFF'  = ARRAY FOR MESSAGE. MUST BE "BUFFSIZE".                      01458000
   LEN    = LENGTH OF MESSAGE IN POSITIVE BYTES.                        01460000
   CRLF   = %320 CONTINUE WITH NO CRLF.                                 01462000
          = 0 CONTINUE NEXT MSG. AFTER CRLF.                            01464000
RETURNS                                                                 01466000
   - LEN IS THE LENGTH OF THE MESSAGE.                                  01468000
   - FINDMSG IS THE RECORD NUMBER OF THE CONTINUED MSG. 0               01470000
     INDICATES NO CONTINUATION.                                         01472000
   - CCG SET NUMBER OF 0, NON-EXISTENT SET OR MESSAGE.                  01474000
   - CCL READCAT FAILED (ATTATCHIO ERROR)                               01476000
;                                                                       01478000
BEGIN                                                                   01480000
   INTEGER ARRAY RECNO'ARRAY(0:2)=Q;                                    01482000
   INTEGER ARRAY HEAD'ARRAY(0:1) =Q;                                    01484000
                                                                        01486000
   INTEGER                                                              01488000
      MAXSETNO = HEAD'ARRAY,    << MAXSETNOCELL >>                      01492000
      NUMRECS  = HEAD'ARRAY +1, << MAXRECELL >>                         01494000
      MSGNOLEN = MAXSETNO;      << MAXSETNO OVERLAID >>        <<02340>>01496000
   LOGICAL                                                              01500000
      SIRN;                                                             01502000
                                                                        01504000
  DOUBLE                                                       <<02340>>01506000
      RECNO'LO,                 << SET'ROFFSET >>              <<02340>>01508000
      RECNO,                    << SET'FIRST'MSG >>            <<02340>>01510000
      RECNO'HI,                 << NEXT'SET'ROFFSET >>         <<02340>>01512000
      RECBND,                                                  <<02340>>01514000
      DUMRECNO,                                                <<02340>>01516000
      RECNO'NEW;                                               <<02340>>01518000
                                                               <<02340>>01520000
   INTEGER                                                              01522000
      VECTOR;                                                           01524000
   BYTE ARRAY BUFF(*)=BUFF';                                            01526000
                                                                        01528000
SUBROUTINE DEF'MOVEFROMDSEG;                                            01530000
                                                                        01532000
INTEGER SUBROUTINE CHKMSGNO(RECTEST);                                   01534000
   VALUE RECTEST;                                                       01536000
   DOUBLE RECTEST;                                             <<02340>>01538000
COMMENT                                                                 01540000
   READS CATALOG & CHECKS TO SEE IF LINE CONTAINS MESSAGE NO.           01542000
   SETS MSGNOLEN.                                                       01544000
;                                                                       01546000
BEGIN                                                                   01548000
      << TEST RECNO LIMITS.MISSING MSGNO WILL FAIL, SINCE >>            01550000
      << LO & HI LIMITS CONTRACT >>                                     01552000
                                                                        01554000
      IF (RECTEST >= RECNO'LO) AND (RECTEST <= RECNO'HI) THEN  <<02340>>01556000
      BEGIN                                                             01558000
         READCAT(RECTEST,BUFF',RECNO'LO,RECNO'HI);             <<04707>>01560000
         IF < THEN CCLRETN;                                             01562000
      END                                                               01564000
      ELSE CCGRETN;                                                     01566000
                                                                        01568000
      << NOW FIND MSGNO IN MSG >>                                       01570000
                                                                        01572000
      << EXTRACT MSGNO LEN FOR BINARY >>                                01574000
      TOS := @BUFF;                                                     01576000
      ASSEMBLE(DUP,DUP);                                                01578000
      MOVE * := * WHILE N,1;                                            01580000
      MSGNOLEN := -(TOS -TOS);                                          01582000
                                                               <<01321>>01584000
<< MAKE SURE CURRENT LINE ISN'T A CONTINUATION LINE. >>        <<01321>>01586000
   IF MSGNOLEN <> 0  AND  RECTEST > RECNO'LO THEN              <<01321>>01588000
   BEGIN                                                       <<01321>>01590000
                                                               <<01321>>01592000
      DUMRECNO := RECTEST -1D;                                 <<02340>>01594000
      READCAT(DUMRECNO,BUFF',RECNO'LO,RECNO'HI);               <<04707>>01596000
      LENBUF( BUFF, LEN, CRLF, DUMRECNO );                     <<01321>>01598000
      IF DUMRECNO = 0D                                         <<02340>>01600000
         THEN READCAT(RECTEST,BUFF',RECNO'LO,RECNO'HI)         <<04707>>01602000
         ELSE MSGNOLEN := 0;                                   <<01321>>01604000
                                                               <<01321>>01606000
   END;                                                        <<01321>>01608000
                                                               <<01321>>01610000
      CHKMSGNO := MSGNOLEN;                                             01612000
END; << CHKMSGNO >>                                                     01614000
                                                                        01616000
<< PROCEDURE MAIN BODY >>                                               01618000
                                                                        01620000
SIRN := GETSIR(MSGSIR);                                                 01622000
   << CAN NOW USE CCRETN MECHANISM >>                                   01624000
                                                                        01626000
CONDCODE := CCE;                                                        01628000
IF MSGDSTN = 0 THEN CCGRETN;                                            01630000
IF MSGNO < 0 THEN CCGRETN;                                              01632000
VECTOR := 1; << MOVE FORWARD INITIALLY >>                               01634000
                                                                        01636000
                                                                        01638000
<< GET MAXSETNO,NUMRECS FROM DIRECTORY >>                               01640000
MOVEFROMDSEG(@HEAD'ARRAY,MSGDSTN,0,2);                                  01642000
                                                                        01644000
IF SETNO < 1   << INVALID SET NO >>                                     01646000
   OR SETNO > MAXSETNO THEN CCGRETN;                                    01648000
                                                                        01650000
<< GET SET'ROFFSET,SET'FIRSTMSG,NEXT'SET'ROFFSET >>                     01652000
MOVEFROMDSEG(@RECNO'ARRAY,MSGDSTN,SETNO*2,3);                           01654000
                                                                        01656000
<< RECNO'LO = SET'ROFFSET >>                                            01658000
<< RECNO    = SET'FIRSTMSG >>                                           01660000
<< RECNO'HI = NEXT'SET'ROFFSET >>                                       01662000
RECNO'LO := DOUBLE(RECNO'ARRAY);                               <<02340>>01664000
RECNO := DOUBLE(RECNO'ARRAY(1));                               <<02340>>01666000
RECNO'HI := DOUBLE(RECNO'ARRAY(2));                            <<02340>>01668000
RECBND := DOUBLE(NUMRECS);                                     <<02340>>01670000
                                                               <<02340>>01672000
IF RECNO = -1D  THEN CCGRETN;  << SET NOT PRESENT >>           <<02340>>01674000
                                                                        01676000
<< SET BOUNDS ON REC. NO. FOR THIS SET >>                               01678000
RECNO'HI := IF SETNO = MAXSETNO THEN DOUBLE(NUMRECS)           <<02340>>01680000
   ELSE RECNO'HI -1D;                                          <<02340>>01682000
                                                                        01684000
<< SET RECNO FOR SETNO,MSGNO >>                                         01686000
RECNO := RECNO'LO + DOUBLE(MSGNO) - RECNO;                     <<02340>>01688000
<< SET'ROFFSET +MSGNO -SET'FIRSTMSG >>                                  01690000
IF RECNO >= RECNO'HI THEN << SET AT UPPER BOUNDS >>                     01692000
BEGIN                                                                   01694000
   RECNO := RECNO'HI;                                                   01696000
   VECTOR := -1;                                                        01698000
END;                                                                    01700000
                                                                        01702000
RECBND := -1D; << FORCES CHKMSGNO CALL 1ST TIME THRU >>        <<02340>>01704000
   << SEARCH FOR CORRECT MSGNO LOOP >>                                  01706000
                                                                        01708000
WHILE TRUE DO                                                           01710000
BEGIN                                                                   01712000
   IF RECBND <> RECNO THEN << GO FETCH A NEW MESSAGE >>                 01714000
      WHILE CHKMSGNO(RECNO) = 0  DO RECNO := RECNO -1D;        <<02340>>01716000
      << IF REC DOESN'T HAVE MSGNO, GO BACKWARDS >>                     01718000
      << NOW HAVE REC CONTAINING MSGNO, FIND IF CORRECT>>               01720000
   TOS := BINARY(BUFF,MSGNOLEN); <<SET IN CHKMSGNO>>                    01722000
   TOS := TOS -MSGNO; DEL;                                              01724000
   IF = THEN << FETCHED CORRECT MSG >>                                  01726000
   BEGIN << MOVE MSG OVER MSGNO & ADJUST LEN >>                         01728000
                                                                        01730000
         << NOW FIND END OF MSG & IF CONT'D. >>                         01732000
      LENBUF(BUFF,LEN,CRLF,RECNO);                                      01734000
      FINDMSG := RECNO;                                                 01736000
                                                                        01738000
      LEN := LEN-(MSGNOLEN +1);                                         01740000
         << MOVE MSG OVER MSGNO        >>                               01742000
         << MESSAGE STARTS 1 PAST MSGNO>>                               01744000
      MOVE BUFF := BUFF(MSGNOLEN +1),(LEN);                             01746000
                                                                        01748000
      GO OUTL; << ONLY SUCCESSFUL EXIT >>                               01750000
                                                                        01752000
   END;                                                                 01754000
                                                                        01756000
      << DIDN'T FIND MSG. NO. NOW BINARY SEARCH >>                      01758000
   IF < THEN VECTOR := +1 ELSE VECTOR := -1;                            01760000
      << IF MSGNO LO, THEN +1.IF HI, THEN -1 >>                         01762000
   RECNO'NEW := (RECNO + DOUBLE(RECNO'ARRAY(1+VECTOR)))/2D;    <<02340>>01764000
      << SET BOUND AT RECORD WITH MSGNO >>                              01766000
   RECBND := RECNO;                                                     01768000
      << BOUNDARY RECORD MUST BE A RECORD CONTAINING A >>               01770000
      << MESSAGE NO. RECBND WILL BE EITHER NEW HI OR LO>>               01772000
   DO RECBND := RECBND + DOUBLE(VECTOR)                        <<02340>>01774000
      UNTIL CHKMSGNO(RECBND) <> 0;                             <<02340>>01776000
   RECNO'ARRAY(1-VECTOR) := INTEGER(RECBND); <<NEW HI OR LO >> <<02340>>01778000
   <<VECTOR=1 THEN WANT RECNO'LO; IF -1 THEN RECNO'HI>>        <<02340>>01780000
   IF VECTOR=1 THEN RECNO'LO:=DOUBLE(RECNO'ARRAY(1-VECTOR))    <<02340>>01782000
    ELSE RECNO'HI:=DOUBLE(RECNO'ARRAY(1-VECTOR));              <<02340>>01784000
                                                               <<02340>>01786000
   RECNO := IF RECNO=RECNO'NEW THEN RECNO+DOUBLE(VECTOR)       <<02340>>01788000
    ELSE IF(RECNO'NEW >= RECNO'LO) AND (RECNO'NEW <= RECNO'HI) <<02340>>01790000
         THEN RECNO'NEW  ELSE DOUBLE(RECNO'ARRAY(1-VECTOR));   <<02340>>01792000
      << IF NEW SAME AS OLD, BUMP. IF NEW FALLS OUT OF>>                01794000
      << LIMITS BECAUSE OF MULTIPLE LINES/MSG SET AT  >>                01796000
      << NEW BOUND                                    >>                01798000
END; << FIND MSGNO LOOP >>                                              01800000
                                                                        01802000
OUTL:                                                                   01804000
      RELSIR(MSGSIR,SIRN);                                              01806000
END; << FINDMSG >>                                                      01808000
$TITLE "FORMSG"                                                         01810000
INTEGER PROCEDURE FORMSG(INBUFF,SETNO,MSGNO,MASK,P1,P2,P3,              01812000
      P4,P5,OUTBUFF,OUTBUFFSIZE,OUTLEN,DEST,CONTROL);                   01814000
   VALUE SETNO,MSGNO,MASK,P1,P2,P3,P4,P5,OUTBUFFSIZE,                   01816000
      DEST,CONTROL;                                                     01818000
   BYTE ARRAY INBUFF,OUTBUFF;                                           01820000
   INTEGER SETNO,MSGNO,OUTBUFFSIZE,DEST,OUTLEN;                         01822000
   LOGICAL MASK,P1,P2,P3,P4,P5,CONTROL;                                 01824000
   OPTION UNCALLABLE;                                                   01826000
COMMENT                                                                 01828000
                                                                        01830000
THIS PROCEDURE ASSEMBLES AND ROUTES MESSAGES. UP TO 5                   01832000
PARAMETERS CAN BE FORMATTED & INSERTED. MESSAGE CAN COME FROM           01834000
MESSAGE CATALOG OR BE PASSED IN. INPUT MESSAGE CAN BE                   01836000
CATENATED WITH STRING IN OUTPUT BUFFER. ASSEMBLED MESSAGE IS            01838000
PLACED IN OUPUT BUFFER. MESSAGE MAY THEN BE ROUTED TO                   01840000
DESTINATION. WHEN OUTPUT BUFFER IS FILLED, MESSAGE IS SENT TO           01842000
DESTINATION & BUFFER REFILLED UNTIL MESSAGE IS COMPLETE.                01844000
                                                                        01846000
INBUFF   INPUT BUFFER. IF IT CONTAINS MESSAGE, MESSAGE MUST             01848000
         TERMINATED BY A ZERO. IF MESSAGE IS IN CATALOG                 01850000
         INBUFF MUST BE 'BUFFSIZE'.                                     01852000
                                                                        01854000
SETNO    MESSAGE SET NUMBER.                                            01856000
         = -1  - MESSAGE IS IN INBUFF.                                  01858000
         = >0  - MESSAGE SET NUMBER IN CATALOG.                         01860000
                                                                        01862000
MSGNO    MESSAGE NUMBER. MUST BE GREATER THAN ZERO.                     01864000
                                                                        01866000
MASK     INDICATES PARAMETER TYPES.                                     01868000
         .(0:1) = NO PARAMETERS.                                        01870000
         .(1:3) = TYPE OF P1.                                           01872000
         .(4:3) = TYPE OF P2.                                           01874000
         .(7:3) = TYPE OF P3.                                           01876000
         .(10:3)= TYPE OF P4.                                           01878000
         .(13:3)= TYPE OF P5.                                           01880000
                                                                        01882000
         TYPE = 0 - PARM IS STRING BYTE POINTER, TERMINATED             01884000
                    BY ZERO.                                            01886000
                1 - PARM IS INTEGER.                                    01888000
                2 - PARM IS DOUBLE BY REFERENCE.                        01890000
                3 - IGNORE THIS PARM.                                   01892000
                                                                        01894000
P1,P2,P3,P4,P5  - PARAMETER, AS INDICATED BY MASK.                      01896000
                                                                        01898000
OUTBUFF  MESSAGE IS SCANNED IN INBUFF & MOVED TO OUTBUFF AS    <<00106>>01900000
         IS FORMATTED. WHEN BUFFER IS FULL, MESSAGE IS                  01902000
         ROUTED.                                               <<01321>>01904000
                                                               <<01321>>01906000
                                                                        01908000
OUTBUFFSIZE  SIZE OF OUTBUFF  IN POSITIVE BYTES.               <<00106>>01910000
                                                                        01912000
OUTLEN   LENGTH OF STRING IN OUTBUFF  IN POSITIVE BYTES.       <<00106>>01914000
         MUST BE SET TO ZERO WHEN FORMSG CALLED IF OUTBUFF  IS <<00106>>01916000
         EMPTY. OUTLEN > 0 INDICATES CATENATION OF STRING               01918000
         IN OUTBUFF  WITH INPUT MESSAGE.                       <<00106>>01920000
                                                                        01922000
DEST     DESTINATION.                                                   01924000
         = -FNUM  - FILE NUMBER.                                        01926000
         = -2     - $STDLIST                                            01928000
         = -1     - NOWHERE--MESSAGE DISAPPEARS.               <<01321>>01930000
         = 0      - NOT USED.                                           01932000
         = LDEV   - TERMINAL.                                           01934000
                                                                        01936000
CONTROL  (TERMINALS ONLY) FLAG WORD.                                    01938000
         .(0:1)  = EACH WRITE WILL HAVE CCTL %320.                      01940000
                                                                        01942000
         .(2:2)  = FUNNY TERMTYPE. TRANSLATE INTO APL.                  01944000
                                                                        01946000
         .(14:2) = IOTYPE FOR ATTACHIO.                                 01948000
                   0 - STANDARD.                                        01950000
                   1 - SOFT PREEMPTION.                                 01952000
                   2 - HARD PREEMTPION.                                 01954000
RETURNS  - THE NEXT MESSAGE VALUE IN THE CURRENT MESSAGE IS             01956000
           RETURNED. IF NONE, -1 IS RETURNED.                           01958000
                                                               <<01321>>01960000
                                                               <<01321>>01962000
CONDITION CODE                                                          01964000
           CCE = EVERYTHING OK                                          01966000
           CCG = SOMETHING WRONG, BUT PRINTED SOMETHING                 01968000
           CCL = I/O FAILURE (ATTACHIO, PRINT, FWRITE).                 01970000
;                                                                       01972000
BEGIN                                                                   01974000
INTEGER                                                                 01976000
   ZEROSTOP,                                                            01978000
   TANKI,                                                               01980000
   INDEX,                                                               01982000
   INLEN,                     <<INPUT BUF: LENGTH  >>                   01984000
   INX,                       <<INPUT BUF: INDEX >>                     01986000
   OUTX,                      <<OUTPUT BUF: INDEX >>                    01988000
   PNUM,                                                                01990000
   FINAL'OUTDEV,    <<ACTUAL DEVICE FOR OUTPUT>>               <<00702>>01992000
   DIT,TERM,                                                   <<00702>>01994000
   DSTX,                                                       <<02802>>01998000
   CRIT,      <<OLD CRITICAL STATE>>                           <<02802>>02000000
   IOQX,      <<ATTACHIO IOQ INDEX>>                           <<02802>>02002000
   SIRN;                                                                02004000
                                                                        02006000
DOUBLE                                                         <<02340>>02008000
   RECNO;                                                      <<02340>>02010000
                                                               <<02340>>02012000
LOGICAL CRLF;                                                           02014000
LOGICAL UP:=TRUE;                                              <<00702>>02016000
EQUATE SYSGLOB=%1000, LPDTBASE=%10, LPDTSIZE=2;                <<00702>>02018000
EQUATE IOMSGPIN = SYSGLOB+%152;   <<SYSDB LOCATION OF PIN>>    <<02802>>02020000
DEFINE IOMSGPROC = ABSOLUTE(IOMSGPIN)/PCBSIZE#;                <<02802>>02022000
DEFINE DIT'UPBIT=DIT).(1:1#,                                   <<00702>>02024000
       DIT'TERM=DIT+7).(5:5#;                                  <<00702>>02026000
                                                               <<01646>>02028000
<< VARIABLES FOR ROUTING DEVICE     >>                         <<01646>>02030000
<< MESSAGES TO THE ASSOCIATED USER. >>                         <<01646>>02032000
                                                               <<01646>>02034000
INTEGER ARRAY                                                  <<01646>>02036000
   MSG'DST'BUF(0:3),    << MESSAGE BUFS HEADER AREA >>         <<02802>>02038000
   ASS'ENT(0:ASS'ENTRYSIZE-1),   << ENTRY FROM ASOC. TABLE >>  <<01646>>02040000
   JMATENTRY(0:JMATENTRYSIZE-1); << ENTRY FROM JMAT >>         <<01646>>02042000
                                                               <<01646>>02044000
INTEGER                                                        <<01646>>02046000
   DIVERT'DEVICE := 0,  << OUTPUT DEVICE FOR ASOC'D USER >>    <<01646>>02048000
   HIGHEST'LDEV;        << LAST LDEV# IN LPDT/ASOC. TABLE >>   <<01646>>02050000
                                                               <<01646>>02052000
                                                                        02054000
POINTER INBUFF';              <<INPUT BUF: WORD PTR>>                   02056000
POINTER OUTBUFF';             <<OUTPUT BUF: WORD PTR >>                 02058000
INTEGER ARRAY PARM'IA(*) = P1;<<PARM BUF: INPUT >>                      02060000
BYTE ARRAY BUFF1(0:11);       <<PARM BUF: OUTPUT >>                     02062000
                                                               <<KS.01>>02064000
   SUBROUTINE LOGIT(DEST);                                     <<KS.01>>02066000
   VALUE DEST;                                                 <<KS.01>>02068000
   INTEGER DEST;                                               <<KS.01>>02070000
   BEGIN                                                       <<KS.01>>02072000
      IF DEST=ABSOLUTE(CONSOLECELL).(8:8)<<OUTPUT TO CONSOLE?>><<KS.01>>02074000
         THEN LOG15(OUTX,@OUTBUFF,OUTX,15); <<THEN LOG IT>>    <<KS.01>>02076000
   END; <<LOGIT>>                                              <<KS.01>>02078000
                                                               <<KS.01>>02080000
SUBROUTINE DEF'MOVETODSEG;                                              02082000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<00552>>02084000
LOGICAL SUBROUTINE DEF'PXGLOB;                                          02086000
INTEGER SUBROUTINE GETXDSBUF;                                  <<02802>>02088000
<< THIS PROCEDURE OBTAINS AN AVAILABLE BUFFER IN >>            <<02802>>02090000
<< THE MSG SYSTEM BUFFER XDS AND RETURNS ITS     >>            <<02802>>02092000
<< INDEX.  IF NO BUFFER IS AVAILABLE, THIS PIN   >>            <<02802>>02094000
<< IS IMPEDED, WAITING FOR A BUFFER.             >>            <<02802>>02096000
BEGIN                                                          <<02802>>02098000
                                                               <<02802>>02100000
<<GET MSG SIR TO INSURE THAT WE HAVE EXCLUSIVE   >>            <<02802>>02102000
<<ACCESS TO THE MSG SYSTEM BUFFER.               >>            <<02802>>02104000
                                                               <<02802>>02106000
TRY'TO'GET'IT'AGAIN:                                           <<02802>>02108000
                                                               <<02802>>02110000
SIRN := GETSIR(MSGSIR);                                        <<02802>>02112000
                                                               <<02802>>02114000
<<MOVE MSG BUF HEADER TO OUR STACK>>                           <<02802>>02116000
MOVEFROMDSEG(@MSG'DST'BUF,IOMSGDST,0,4);                       <<02802>>02118000
                                                               <<02802>>02120000
<<OBTAIN NEXT BUFFER IN CHAIN>>                                <<02802>>02122000
IF MSG'DST'BUF(2) = 0 THEN                                     <<02802>>02124000
  BEGIN  <<ALL BUFFERS ARE CURRENTLY BEING USED>>              <<02802>>02126000
  PDISABLE;                                                    <<02802>>02128000
  RELSIR(MSGSIR,SIRN); <<RELEASE SIR>>                         <<02802>>02130000
  <<LINK THIS PCB INTO QUEUE FOR BUFFER>>                      <<02802>>02132000
  TOS := MYPIN;                                                <<02802>>02134000
  TOS := IOMSGQUEUE;   <<FIRST PCB WAITING>>                   <<02802>>02136000
  IF = THEN                                                    <<02802>>02138000
    BEGIN << THIS PIN IS TO BE FIRST IN-LINE >>                <<02802>>02140000
    ASSEMBLE(XCH); << PUT MY PIN ON TOS >>                     <<02802>>02142000
    IOMSGQUEUE := TOS; << SAVE PIN IN IMPEDE LIST >>           <<02802>>02144000
                                                               <<02802>>02146000
    << SINCE THIS IS 1ST IN LINE, WAKEN IOMSGPROC AS IF >>     <<02802>>02148000
    << A TIMER POPPED, SO IT CAN SET UP A WATCHDOG TIMER>>     <<02802>>02150000
    AWAKE(ABSOLUTE(IOMSGPIN),%10<<TIMER>>,0);                  <<02802>>02152000
                                                               <<02802>>02154000
    END                                                        <<02802>>02156000
  ELSE                                                         <<02802>>02158000
    BEGIN  << THERE ARE OTHER PINS WAITING >>                  <<02802>>02160000
    DO TOS:=ABSOLUTE((TOS*PCBSIZE)+ABSOLUTE(PCBB)+PCB8).NIMPPIN<<02802>>02162000
       UNTIL =; << FIND END PIN ON LIST >>                     <<02802>>02164000
    ASSEMBLE(XCH);  << PUT MY PIN ON TOS >>                    <<02802>>02166000
    ABSOLUTE(X).NIMPPIN:=S0;<< STORE MY PIN IN NIMP >>         <<02802>>02168000
    ASSEMBLE(DEL);  << REMOVE MY PIN FROM TOS >>               <<02802>>02170000
    END;                                                       <<02802>>02172000
                                                               <<02802>>02174000
  << MAKE SURE MY NIMP IS ZERO >>                              <<02802>>02176000
  ABSOLUTE(CPCB+PCB8).NIMPPIN := 0;                            <<02802>>02178000
  << IMPEDE, WAITING FOR IOMSGPROC TO RELEASE A BUFFER >>      <<02802>>02180000
  IMPEDE(*);  << ZERO WAS LEFT ON TOS >>                       <<02802>>02182000
                                                               <<02802>>02184000
  << NOW, GO AND TRY OBTAINING BUFFER ALL OVER AGAIN >>        <<02802>>02186000
  GO TO TRY'TO'GET'IT'AGAIN;                                   <<02802>>02188000
  END                                                          <<02802>>02190000
ELSE                                                           <<02802>>02192000
  BEGIN  << THERE IS AN AVAIL BUFFER, SO DO NECESSARY LINKING ><<02802>>02194000
                                                               <<02802>>02196000
  << SEE IF NEXT POINTER IS VALID >>                           <<02802>>02198000
  IF MSG'DST'BUF(2) > (MSG'DST'BUF*MSG'DST'BUF(1)) <<OUT OF TAB<<02802>>02200000
     OR                                                        <<02802>>02202000
     (MSG'DST'BUF(2)-4) MOD MSG'DST'BUF(1) <> 0 THEN << BOUNDAR<<02802>>02204000
    BEGIN                                                      <<02802>>02206000
    RELSIR(MSGSIR,SIRN);                                       <<02802>>02208000
    RETURN;    << NO GOOD - PROBLEM EXISTS >>                  <<02802>>02210000
    END;                                                       <<02802>>02212000
                                                               <<02802>>02214000
  << SAVE INDEX AS RETURN FROM TYPED SUBROUTINE >>             <<02802>>02216000
  GETXDSBUF := MSG'DST'BUF(2);                                 <<02802>>02218000
                                                               <<02802>>02220000
  << UPDATE POINTER TO NEXT AVAILABLE BUFFER >>                <<02802>>02222000
  MOVEFROMDSEG(@MSG'DST'BUF(2),IOMSGDST,MSG'DST'BUF(2),1);     <<02802>>02224000
  << IF THIS IS THE END OF AVAIL BUFS, MARK TRLR 0 >>          <<02802>>02226000
  IF MSG'DST'BUF(2) = 0 THEN                                   <<02802>>02228000
    MSG'DST'BUF(3) := 0;                                       <<02802>>02230000
  MOVETODSEG(IOMSGDST,2,@MSG'DST'BUF(2),2);                    <<02802>>02232000
                                                               <<02802>>02234000
  RELSIR(MSGSIR,SIRN);                                         <<02802>>02236000
  END;                                                         <<02802>>02238000
END;  << OF SUBROUTINE GETXDSBUF >>                            <<02802>>02240000
                                                                        02242000
SUBROUTINE PRINTIT; << HANDLES ROUTING OF OUTPUT >>                     02244000
BEGIN                                                                   02246000
   IF CONTROL.FUNNYTERM <> 0 THEN << TRANSLATE INTO APL >>              02248000
      APLTRANSLATEOUT(OUTBUFF,OUTX,CONTROL.FUNNYTERM);                  02250000
   IF CONTROL&CSL(1) THEN CRLF := %320; << OVERRIDE >>                  02252000
   IF DEST < 0 THEN << RETURN STRING OR FWRITE >>                       02254000
   BEGIN  << $STDLIST IS DONE HERE >>                                   02256000
      IF DEST < -1 THEN << FWRITE >>                                    02258000
      BEGIN                                                             02260000
         IF (DEST = -2)  AND  PXGLOB(6).(3:1) <<session>>  AND <<01998>>02262000
            JOBSESSIONMAIN THEN                                <<01998>>02264000
         BEGIN                                                          02266000
            TOS :=ATTACHIO(PXGLOB(3).(8:8),0,0,@OUTBUFF',1,             02268000
               -OUTX,CRLF,0,1); << BYPASS FILESYS >>                    02270000
         DEL;                                                           02272000
         IF TOS.(13:3) <> 1 THEN CCLRETN;                               02274000
         END                                                            02276000
         ELSE                                                           02278000
         BEGIN                                                          02280000
            FWRITE(-DEST,OUTBUFF',-OUTX,CRLF);                          02282000
            IF <> THEN CCLRETN;                                         02284000
         END;                                                           02286000
      END;                                                              02288000
      << DEST = -1, DO NOTHING.  MESSAGE DISAPPEARS. >>        <<01321>>02290000
   END                                                                  02292000
   ELSE << DEST >= 0, GO TO SOME DEVICE - NO WAIT I/O>>                 02294000
   BEGIN                                                                02296000
         LOGIT(DEST); <<LOG MESSAGE POSSIBLE CONSOLE MSG>>     <<KS.01>>02298000
                                                               <<02802>>02302000
      << MAKE SURE ENOUGH STACK IS HERE B/4 CRITICAL >>        <<02802>>02304000
      ASSEMBLE(ADDS 255;SUBS 255);                             <<02802>>02306000
                                                               <<02802>>02308000
      << SET CRITICAL TO NOT ABORT WHILE OWNING BUFFERS >>     <<02802>>02310000
      CRIT := SETCRITICAL;                                     <<02802>>02312000
                                                               <<02802>>02314000
      << GET BUFFER INDEX TO PLACE MESSAGE INTO >>             <<02802>>02316000
      DSTX := GETXDSBUF;                                       <<02802>>02318000
      IF DSTX = 0 THEN                                         <<02802>>02320000
        BEGIN  << FAILED TO GET A BUFFER >>                    <<02802>>02322000
        RESETCRITICAL(CRIT);                                   <<02802>>02324000
        CCLRETN;                                               <<02802>>02326000
        END;                                                   <<02802>>02328000
                                                               <<02802>>02330000
      << MOVE DATA TO XDS >>                                   <<02802>>02332000
      MOVETODSEG(IOMSGDST,DSTX,@OUTBUFF',(OUTX+1)&LSR(1));     <<02802>>02334000
                                                               <<00702>>02336000
<< FIRST DETERMINE ACTUAL OUTPUT DEVICE,  THEN IF SYSTEM >>    <<00702>>02338000
<< CONSOLE AND NOT LOGGED ON, ALLOCATE                   >>    <<00702>>02340000
<< OUTPUT MESSAGE, AND IF AN ALLOCATION WAS DONE, THEN   >>    <<00702>>02342000
<< DEALLOCATE DEVICE                                     >>    <<00702>>02344000
                                                               <<00702>>02346000
FINAL'OUTDEV:=IF DIVERT'DEVICE=0 THEN DEST ELSE DIVERT'DEVICE; <<00702>>02348000
IF FINAL'OUTDEV=ABSOLUTE(CONSOLECELL).(8:8) THEN <<SYS CONSOLE><<00702>>02350000
BEGIN                                                          <<00702>>02352000
   << Turn traps off in case LPDT is to high up >>             <<04265>>02354000
   << We could get an integer overflow and sf 311 >>           <<04265>>02356000
   PUSH(STATUS);                                               <<04265>>02358000
   TOS.(2:1) := 0;                                             <<04265>>02360000
   SET(STATUS);                                                <<04265>>02362000
   DIT:=ABSOLUTE(SYSGLOB+ABSOLUTE(LPDTBASE+SYSGLOB)            <<00702>>02364000
                 + LPDTSIZE*FINAL'OUTDEV)+SYSGLOB;             <<00702>>02366000
   << Put traps back on >>                                     <<04265>>02368000
   PUSH(STATUS);                                               <<04265>>02370000
   TOS.(2:1) := 1;                                             <<04265>>02372000
   SET(STATUS);                                                <<04265>>02374000
   UP:=ABSOLUTE(DIT'UPBIT);                                    <<00702>>02376000
<< TERM:=ABSOLUTE(DIT'TERM); >>  << USE DEFAULT TERM TYPE >>   <<02316>>02378000
   IF NOT UP THEN                                              <<00702>>02380000
      ATTACHIO(FINAL'OUTDEV,0,0,0,24,0,0,0,1);                 <<02316>>02382000
END;                                                           <<00702>>02384000
                                                               <<00702>>02386000
      TOS := ATTACHIO(FINAL'OUTDEV                             <<02802>>02388000
             ,0,IOMSGDST, << WHERE MESSAGE WAS PUT>>           <<02802>>02390000
          DSTX,1,-OUTX,CRLF,0,CONTROL.(14:2)&LSL(7));          <<02802>>02392000
      ASSEMBLE(DEL);                                           <<02802>>02394000
      IOQX := TOS;   <<STORE IOQ INDEX>>                       <<02802>>02396000
      IF NOT UP THEN ATTACHIO(FINAL'OUTDEV,0,0,0,4,0,0,0,1);   <<00702>>02398000
   <<SEND IOQ TO IOMESSAGEPROC TO WAIT FOR COMPLETION>>        <<02802>>02400000
   TOS := 2;  <<MSG TYPE 2 IS IOQ>>                            <<02802>>02402000
   TOS := IOQX; <<IOQ INDEX>>                                  <<02802>>02404000
   TOS := DSTX; <<DST USED TO PERFORM I/O>>                    <<02802>>02406000
   TOS := 0;    <<NOT USED>>                                   <<02802>>02408000
   SENDMSG(IOMSGPROC,0<<PORT 0>>,4<<LENGTH OF MSG>>,%140000);  <<02802>>02410000
                                                               <<02802>>02412000
   <<RESET CRITICAL SO CAN ABORT NOW>>                         <<02802>>02414000
   RESETCRITICAL(CRIT);                                        <<02802>>02416000
                                                               <<02802>>02418000
   END;                                                                 02420000
                                                                        02422000
   OUTLEN := OUTX; <<INDICATE CONTENTS OF OUTBUFF>>                     02424000
   OUTX := 0; <<RESET INDEX TO REFILL OUTBUFF>>                         02426000
END; << PRINTIT >>                                                      02428000
                                                                        02430000
SUBROUTINE TANK(LENGTH,STRING);                                         02432000
   VALUE LENGTH;                                                        02434000
   INTEGER LENGTH;                                                      02436000
   BYTE ARRAY STRING;                                                   02438000
BEGIN                                                                   02440000
   IF LENGTH=0 THEN RETURN;                                    <<00106>>02442000
   TANKI := -1;                                                         02444000
   WHILE (TANKI := TANKI+1) < LENGTH DO << TANKING LOOP>>               02446000
   BEGIN                                                                02448000
      IF OUTX >= OUTBUFFSIZE THEN PRINTIT; <<FLUSH OUTBUFF>>   <<00106>>02450000
      OUTBUFF(OUTX) := STRING(TANKI);                          <<00106>>02452000
      OUTX := OUTX+1;                                          <<00106>>02454000
   END; <<TANK LOOP>>                                                   02456000
END; << TANK >>                                                         02458000
                                                                        02460000
SUBROUTINE INSERTPARM;                                                  02462000
BEGIN                                                                   02464000
   << CATCH BOUNDARY CONDITION ON LAST CHAR "!" >>             <<00261>>02466000
   IF PNUM >= 5 THEN RETURN;                                   <<00261>>02468000
   CASE *INTEGER((MASK &CSL(4+PNUM*3)) LAND 3) OF << PARM X >>          02470000
   BEGIN                                                                02472000
      BEGIN << 0: STRING PARM >>                                        02474000
         TOS := PARM'IA(PNUM);                                          02476000
         ASSEMBLE(DUP,DUP);                                             02478000
         SCAN * UNTIL 0,1;                                              02480000
         ASSEMBLE(XCH,SUB;XCH);                                         02482000
         TANK(*,*);                                                     02484000
      END;                                                              02486000
                                                                        02488000
      << 1: INTEGER BY VALUE >>                                         02490000
      BEGIN                                                    <<01456>>02492000
                                                               <<01456>>02494000
      IF INBUFF(INDEX) = "\" THEN << EXPECT LDEV # >>          <<01456>>02496000
      BEGIN                                                    <<01456>>02498000
         HIGHEST'LDEV := ABSOLUTE(SYSGLOB +                    <<01456>>02500000
                         ABSOLUTE(SYSGLOB + LPDTBASE)).(0:8);  <<01456>>02502000
         IF 1 <= PARM'IA(PNUM) <= HIGHEST'LDEV THEN            <<01456>>02504000
         BEGIN   << VALID LDEV >>                              <<01456>>02506000
            << GET ASSOCIATE TABLE ENTRY FOR LDEV >>           <<01456>>02508000
            SIRN := GETSIR(ASS'SIR);  << LOCK ASOC. TABLE >>   <<01646>>02510000
            MOVEFROMDSEG(@ASS'ENT,ASS'DST,                     <<01456>>02512000
               PARM'IA(PNUM)*ASS'ENTRYSIZE,ASS'ENTRYSIZE);     <<01646>>02514000
            IF ASS'ENT(ASS'JMAT)<>0 THEN <<LDEV IS ASSOCIATED>><<01456>>02516000
            BEGIN                                              <<01456>>02518000
               << GET NEW LDEV FROM JMAT ENTRY >>              <<01456>>02520000
               MOVEFROMDSEG(@JMATENTRY,JMATDST,                <<01456>>02522000
                ASS'ENT(ASS'JMAT)*JMATENTRYSIZE,JMATENTRYSIZE);<<01456>>02524000
               DIVERT'DEVICE := JMATENTRY(JMAT'OUTDEV);        <<01456>>02526000
            END;                                               <<01456>>02528000
            << DON'T RELEASE ASOC. TABLE UNTIL AFTER GETTING >><<01646>>02530000
            << JMAT ENTRY TO ENSURE ITS VALIDITY.            >><<01646>>02532000
            RELSIR(ASS'SIR,SIRN);                              <<01646>>02534000
         END;                                                  <<01456>>02536000
      END;                                                     <<01456>>02538000
                                                               <<01456>>02540000
      TANK(ASCII(PARM'IA(PNUM),10,BUFF1),BUFF1);                        02542000
                                                               <<01456>>02544000
      END;  << OF INTEGER BY VALUE >>                          <<01456>>02546000
                                                                        02548000
      << 2: DOUBLE BY REFERENCE >>                                      02550000
      BEGIN                                                             02552000
         TOS := PARM'IA(PNUM);                                          02554000
         TANK(DASCII(DPS0,10,BUFF1),BUFF1); DEL;                        02556000
      END;                                                              02558000
                                                                        02560000
      ;<< 3 IGNORE PARM >>                                              02562000
                                                                        02564000
   END; << CASE OF PARMS >>                                             02566000
   PNUM := PNUM+1;                                                      02568000
END; <<INSERTPARM>>                                                     02570000
                                                                        02572000
<< MAIN BODY >>                                                         02574000
                                                                        02576000
                                                                        02578000
<< SET UP VARIABLES >>                                                  02580000
CRLF := ZEROSTOP := 0; << STOPPER FOR INPUT STRING SCAN >>              02582000
CONDCODE := CCE;                                                        02584000
FORMSG := -1; << SET TO NO CONTINUATION >>                              02586000
@INBUFF' := @INBUFF &LSR(1);                                            02588000
@OUTBUFF' := @OUTBUFF & LSR(1);                                         02590000
                                                                        02592000
<< STRING PASSED IN, OR CATALOG FETCH ? >>                              02594000
IF SETNO = -1 THEN                                                      02596000
                                                                        02598000
<< STRING PASSED IN >>                                                  02600000
                                                                        02602000
BEGIN                                                                   02604000
   SCAN INBUFF UNTIL 0,1; << STOPPED BY ZEROSTOP>>                      02606000
   INLEN := TOS -@INBUFF;                                               02608000
   RECNO := 0D;  << INDICATE NO CONTINUED MSGS >>              <<02340>>02610000
END                                                                     02612000
ELSE                                                                    02614000
                                                                        02616000
<< FETCH FROM CATALOG >>                                                02618000
                                                                        02620000
BEGIN                                                                   02622000
   RECNO := FINDMSG(SETNO,MSGNO,INBUFF',INLEN,CRLF);                    02624000
   IF < THEN CCLRETN;                                                   02626000
   IF > THEN <<CAN'T FIND MSG. PRINT DIAG. MSG>>                        02628000
   BEGIN                                                                02630000
      MOVE INBUFF := ("MISSING MSG. SET=!. MESSAGE=!.",0);              02632000
      GENMSG(-1,@INBUFF,%11000,SETNO,MSGNO,,,,DEST,                     02634000
         ,,,CONTROL.(14:2));                                            02636000
      IF NOT MASK&CSL(1) THEN                                           02638000
      BEGIN                                                             02640000
         MOVE INBUFF := ("PARM(S)= !;!;!;!;!",0);                       02642000
         GENMSG(-1,@INBUFF,MASK,P1,P2,P3,P4,P5,                         02644000
            DEST,,,,CONTROL.(14:2));                                    02646000
      << IF PARMS PRESENT THEN PRINT THEM >>                            02648000
      END;                                                              02650000
      CCGRETN;                                                          02652000
   END;                                                                 02654000
END;                                                                    02656000
                                                                        02658000
<< SET UP LOOP VARIABLES >>                                             02660000
PNUM := INDEX := INX := OUTX := 0;                                      02662000
OUTX := OUTLEN; << SKIP PAST ANY INITIAL STUFF >>                       02664000
                                                                        02666000
<< NOW GO TO WORK ON INPUT STRING & FORMAT >>                           02668000
                                                                        02670000
LOOP:                                                                   02672000
   IF (INBUFF(INDEX) = "!") OR                                 <<01456>>02674000
      (INBUFF(INDEX) = "\") THEN <<INSERT PARM OR NEXT MSGNO?>><<01456>>02676000
   BEGIN                                                                02678000
      TANK(INDEX-INX,INBUFF(INX));<<DUMP BUFF UP TO !>>                 02680000
      IF INBUFF(INDEX+1)=NUMERIC AND INLEN >INDEX+1 THEN                02682000
      BEGIN <<NEXT MSGNO !XXX >>                                        02684000
         FORMSG := BINARY(INBUFF(X),INLEN-X);                           02686000
         IF <> THEN CONDCODE:= CCG; <<BAD NEXTMSG>>                     02688000
         INLEN := INDEX;                                                02690000
         INX := INDEX + 1;  << ADVANCE PAST "!" >>             <<01524>>02692000
      END                                                               02694000
      ELSE                                                              02696000
      IF NOT MASK&CSL(1) THEN                                           02698000
      BEGIN << PARMS PRESENT >>                                         02700000
         INSERTPARM;                                                    02702000
         INX := INDEX+1; << ADVANCE PAST !>>                            02704000
      END                                                               02706000
      ELSE INX := INDEX; <<! WASN'T PARM >>                             02708000
   END;                                                                 02710000
                                                                        02712000
   << REFILL BUFF? >>                                                   02714000
   IF INDEX>=INLEN-1 THEN <<END OF LINE>>                      <<00616>>02716000
   BEGIN                                                                02718000
      IF INLEN>=0 THEN TANK(INDEX-INX+1,INBUFF(INX));          <<00662>>02720000
      IF OUTX <>0  << FLUSH OUT >>                                      02722000
         OR INLEN = 0 << NEED CRLF >> THEN PRINTIT;                     02724000
      INX := INDEX:= 0;                                                 02726000
      IF RECNO <> 0D THEN                                      <<02340>>02728000
      BEGIN                                                             02730000
         SIRN := GETSIR(MSGSIR);                                        02732000
         READCAT(RECNO,INBUFF',0D,0D); << No search block >>   <<04707>>02734000
            << NOW GET LENGTH,CRLF, CONT'D >>                           02736000
         IF < THEN CONDCODE := CCL;                                     02738000
         LENBUF(INBUFF,INLEN,CRLF,RECNO);                               02740000
         RELSIR(MSGSIR,SIRN);                                           02742000
         IF CONDCODE = CCL THEN RETURN;                                 02744000
         INDEX := -1; << RESET FOR LOOP>>                               02746000
      END                                                               02748000
      ELSE                                                              02750000
      GO OUTL << ALL FINISHED >>                                        02752000
   END;                                                                 02754000
   INDEX := INDEX+1;                                                    02756000
GO LOOP; <<END SCAN THRU MSG LOOP >>                                    02758000
                                                                        02760000
OUTL:                                                                   02762000
                                                                        02764000
END; << FORMSG >>                                                       02766000
$PAGE "GENMSG"                                                          02768000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,MASK,PARM1,PARM2,                  02770000
      PARM3,PARM4,PARM5,DEST,REPLY,OFFSET,DST,CONTROL);                 02772000
   VALUE   SETNO,MSGNO,MASK,PARM1,PARM2,PARM3,PARM4,PARM5,              02774000
           DEST,REPLY,OFFSET,DST,CONTROL;                               02776000
   INTEGER SETNO,MSGNO,DEST,DST;                                        02778000
   LOGICAL MASK,PARM1,PARM2,PARM3,PARM4,PARM5,REPLY,OFFSET,             02780000
      CONTROL;                                                          02782000
   OPTION VARIABLE,PRIVILEGED,UNCALLABLE;                               02784000
COMMENT                                                                 02786000
   THIS PROCEDURE IS A GENERAL MESSAGE HANDLER. IT FEATURES:            02788000
   - FINDING A MESSAGE IN THE MESSAGE CATALOG & PRINTING IT.            02790000
                                                               <<01321>>02792000
   - INSERTING PARAMETERS INTO MESSAGES, EITHER FROM THE                02794000
     MESSAGE CATALOG OR FROM AN INPUT STRING.                           02796000
   - PRINTING A MESSAGE ON $STDLIST, THE SYSTEM CONSOLE,                02798000
     TO A SPECIFIED LDEV, OR TO A FILE.                                 02800000
   - RETURNING THE NEXT MESSAGE NUMBER AS SPECIFIED IN THE              02802000
     MESSAGE CATALOG.                                                   02804000
PARAMETERS                                                              02806000
   SETNO - REQUIRED PARM. SET NUMBER FROM CATALOG.                      02808000
   MSGNO - REQUIRED PARM.                                               02810000
           IF SETNO > 0  - MESSAGE NUMBER WITHIN MESSAGE SET.           02812000
                           MSGNO >= 0.                                  02814000
           IF SETNO = -1 - STRING TO BE FORMATTED IS PASSED IN,         02816000
                           RATHER THAN FOUND IN CATALOG.                02818000
                           'MSGNO' CONTAINS BYTE ADDRESS ON             02820000
                           WORD BOUNDARY. STRING MUST BE                02822000
                           TERMINATED BY ZERO.                          02824000
           IF SETNO =-2  - SAME AS -1, EXCEPT CCTL = %320               02826000
                           INSTEAD OF 0.                                02828000
   MASK  - INDICATES TYPES OF ANY PARAMETERS WHICH ARE PASSED.          02830000
           MASK.(1:3) = TYPE OF PARM1.                                  02832000
           MASK.(4:3) = TYPE OF PARM2.                                  02834000
           MASK.(7:3) = TYPE OF PARM3.                                  02836000
           MASK.(10:3)= TYPE OF PARM4.                                  02838000
           MASK.(13:3)= TYPE OF PARM5.                                  02840000
                                                                        02842000
           TYPE = 0 - PARM IS STRING BYTE POINTER (I.E.                 02844000
                      @STRING). STRING IS TERMINATED BY ZERO.           02846000
                  1 - PARM IS INTEGER BY VALUE.                         02848000
                  2 - PARM IS DOUBLE BY REFERENCE (I.E.                 02850000
                      @DOUBLE).                                         02852000
   PARMX - PARAMETER, AS INDICATED BY MASK. PARM1 SUBSTITUTES           02854000
           FOR THE LEFTMOST PARAMETER IN THE MESSAGE, PARM2             02856000
           FOR THE NEXT PARAMETER TO THE RIGHT, AND SO FORTH.           02858000
           IF PARM(N) IF PRESENT, PARM(N-1) MUST BE PRESENT.            02860000
           IF PARM IS A STRING, A BYTE ADDRESS MUST BE PASSED           02862000
           (I.E. @STRING).                                              02864000
   DEST  - DESTINATION OF MESSAGE.                                      02866000
           MISSING - PRINT ON $STDLIST. FOR SYSTEM PROCESSES,           02868000
                     NO PCB/NO WAIT I/0 TO CONSOLE. SOFT-               02870000
                     PREEMPTION IS DONE                                 02872000
           = < -2  - NEGATIVE FILE NUMBER. FWRITE TO -DEST IS           02874000
                     DONE.                                              02876000
           = -2    - $STDLIST. IF SYSTEM PROCESS, THEN NO PCB/          02878000
                     NO WAIT I/O TO CONSOLE. SOFT-PREEMPTION            02880000
                     IS DEFAULT.                                        02882000
           = -1    - NOWHERE.  MESSAGE DISAPPEARS.             <<01321>>02884000
           = 0     - CONSOLE, NO PCB/NO WAIT I/O. SOFT-                 02886000
                     PREEMPTION IS DEFAULT.                             02888000
                     PREFIX IS ADDED TO MSG CONTAINING TIME             02890000
                     STAMP/[#J/S]/PIN/.                                 02892000
   REPLY - (CONSOLE ONLY). FORMAT SPECIFICATIONS FOR REPLY.             02894000
           XPECTED FROM CONSOLE MESSAGE.                                02896000
           REPLY.( 0:8) = MAXIMUM STRING LENGTH                         02898000
                          (REPLY TYPE 2 & 4 ONLY).             <<00813>>02900000
                                                                        02902000
           REPLY.(8:8) = REPLY TYPE.                           <<00620>>02904000
                         0 - NUMBER                                     02906000
                         1 - YES OR NO                                  02908000
                         2 - STRING                                     02910000
                         3 - YES/NO OR NUMBER                  <<00620>>02912000
                         4 - ONE STRING. (CURRENTLY USED FOR   <<00620>>02914000
                                  THE INTRINSIC PRINTOPREPLY)  <<00620>>02916000
   OFFSET- (CONSOLE ONLY). WORD ADDRESS FOR FORMATTED REPLY.            02918000
           IF 'DST' IS PRESENT, THEN SEGMENT RELATIVE,                  02920000
           OTHERWISE DB RELATIVE. REPLIES ARE FORMATTED AS              02922000
           FOLLOWS:                                                     02924000
           REPLY TYPE   CONTENTS AT 'OFFSET'                            02926000
           ----------   -------------------                             02928000
           0 -(NUM)     BINARY VALUE OF NUMBER TYPED BY                 02930000
                        OPERATOR.                                       02932000
           1 -(Y/N)     TRUE FOR "YES", FALSE FOR "NO".                 02934000
           2 -(STRING)  FIRST WORD CONTAINS CHARACTER COUNT.            02936000
                        STRING STARTS AT SECOND WORD.                   02938000
           3 -(NUM OR                                          <<00620>>02940000
                  Y/N)   SAME AS EITHER REPLY TYPES 0 OR 1     <<00620>>02942000
           4 -(1 STRING) SAME AS REPLY TYPE 2                  <<00620>>02944000
   DST   - (CONSOLE ONLY). IF PRESENT INDICATES DATA SEGMENT            02946000
           FOR REPLY.                                                   02948000
   CONTROL - (TERMINALS ONLY) FLAG WORD.                                02950000
             .(0:1)  = EACH WRITE WILL HAVE CCTL %320.                  02952000
                                                                        02954000
             .(2:2)  = FUNNY TERMTYPE. TRANSLATE INTO APL.              02956000
                                                                        02958000
             .(14:2) = IOTYPE FOR ATTACHIO.                             02960000
                       0 - STANDARD.                                    02962000
                       1 - SOFT PREEMPTION.                             02964000
                       2 - HARD PREEMTPION.                             02966000
CONSOLE REPLY RULES.                                                    02968000
   REPLIES ARE FORMATTED BY PROGEN AND RESULT (NOT RAW INPUT            02970000
   AT CONSOLE) IS PLACED IN 'OFFSET'. A '?' IS PLACED AT THE            02972000
   BEGINNING OF THE MESSAGE. TYPE OF REPLY EXPECTED MUST BE IN          02974000
   THE MESSAGE ITSELF (I.E. '(Y/N)' MUST BE SUPPLIED).                  02976000
   MESSAGES REQUIRING A REPLY ARE TRUNCATED IN REPLY                    02978000
   INFORMATION TABLE (CURRENT LIMIT = 74 -TOTAL PREFIX SIZE).           02980000
RETURNS                                                                 02982000
   NEXT MESSAGE NUMBER FROM CATALOG (!XXX). IF NONE, -1 IS              02984000
   RETURNED.                                                            02986000
CONDITION CODE                                                          02988000
   CCE = EVERYTHING OK                                                  02990000
   CCL = I/O FAILURE (ATTACHIO, FWRITE).                                02992000
   CCG = SOMETHING WRONG WITH CALL.  TRIED BEST TO PRINT SOMETHING.     02994000
;                                                                       02996000
BEGIN                                                                   02998000
                                                                        03000000
INTEGER                                                                 03002000
   ZERO := 0,                                                  <<00813>>03004000
   LEN,                                                                 03006000
   OUTBUFFSIZE,                                                         03008000
   INDEX = OUTBUFFSIZE,                                                 03010000
   FUNNYSCR = OUTBUFFSIZE;                                              03012000
                                                                        03014000
LOGICAL CONSOLE; << INDICATES TO ADD PREFIX >>                          03016000
                                                                        03018000
BYTE POINTER INBUFF;                                                    03020000
INTEGER TMP;                                                   <<04882>>03022000
LOGICAL PENDING; << USED TO EXIT PROCEDURE W/O OP REPLY >>     <<04882>>03024000
LOGICAL NOPROBLEM;                                             <<04882>>03026000
POINTER OUTBUFF';                                                       03028000
POINTER CONSBUFF';                                                      03030000
ARRAY                                                          <<00813>>03032000
   CHAR'ZERO(0:1);                                             <<00813>>03034000
                                                                        03036000
                                                                        03038000
SUBROUTINE DEF'MOVEFROMDSEG;                                            03040000
SUBROUTINE DEF'MOVETODSEG;                                     <<00813>>03042000
                                                                        03044000
INTEGER SUBROUTINE DEF'PXGLOB;                                          03046000
                                                                        03048000
SUBROUTINE MASKPARMS;                                                   03050000
BEGIN                                                                   03052000
                                                                        03054000
IF PMASK.PPMASK AND NOT MASK&CSL(1) THEN                                03056000
BEGIN                                                                   03058000
   PMASK := PMASK &CSR(5); <<RIGHT JUSTIFY>>                            03060000
   INDEX := 0;                                                          03062000
   DO BEGIN                                                             03064000
      IF NOT PMASK &CSR(INDEX) THEN MASK.(13:3)                         03066000
         := 3; << IGNORE PARM >>                                        03068000
      MASK := MASK &CSR(3);                                             03070000
   END UNTIL (INDEX := INDEX+1) >=5;                                    03072000
   PMASK := PMASK &CSL(5);                                              03074000
   MASK := MASK &CSR(1);                                                03076000
END                                                                     03078000
ELSE MASK := -1; <<IGNORE ALL PARMS>>                                   03080000
                                                                        03082000
END; << MASKPARMS >>                                                    03084000
                                                                        03086000
                                                                        03088000
<< MAIN PROCEDURE BODY >>                                               03090000
                                                                        03092000
<<***** VARIABLE SET-UP       *****>>                                   03094000
PENDING := TRUE;  << ASSUME THERE IS ROOM >>                   <<04882>>03096000
CONDCODE := CCE;                                                        03098000
CONSOLE := << FALSE >> LEN := 0;                                        03100000
                                                                        03102000
<<***** CHECK REQUIRED PARMS       *****>>                              03104000
                                                                        03106000
IF NOT (PMASK.PSETNO LOR PMASK.PMSGNO) THEN                             03108000
   CCGRETN; << OMITTED REQUIRED PARMS >>                                03110000
IF PMASK.PREPLY AND NOT PMASK.POFFSET THEN CCGRETN;                     03112000
<< OFFSET REQUIRED FOR REPLY >>                                         03114000
                                                                        03116000
<<***** SET-UP PARMS          *****>>                                   03118000
                                                                        03120000
MASKPARMS;                                                              03122000
                                                                        03124000
<<***** SET-UP CONTROL      *****>>                                     03126000
                                                                        03128000
IF NOT PMASK.PCONTROL THEN CONTROL := 0;                                03130000
                                                                        03132000
<<***** RESOLVE DESTINATION ******>>                                    03134000
<<      AND PREEMPTION            >>                                    03136000
                                                                        03138000
IF PMASK.PDEST THEN                                                     03140000
BEGIN << DEST SUPPLIED, NOT $STDLIST >>                                 03142000
   IF DEST > 0 THEN                                                     03144000
   BEGIN << CHECK FOR VALID LDEV, MAY BE SPOOLED >>                     03146000
      IF INTEGER(ABSOLUTE(ABSOLUTE(%1010)+DEST*2+%1000)) < 0            03148000
         THEN CCGRETN;                                                  03150000
   END;                                                                 03152000
   IF DEST = -2 AND SYSPROC THEN                                        03154000
   BEGIN << $STDLIST FOR SYSTEM PROC. IS CONSOLE >>                     03156000
      DEST := ABSOLUTE(CONSOLECELL).(8:8);                              03158000
      IF CONTROL.(14:2) = 0 THEN CONTROL.(14:2) := 1;                   03160000
         << FORCE SOFT-PREEMPTIVE >>                                    03162000
   END;                                                                 03164000
   IF DEST = 0 THEN << CONSOLE MSG. NEEDS PREFIX >>                     03166000
   BEGIN                                                                03168000
      DEST := ABSOLUTE(CONSOLECELL).(8:8);                              03170000
      CONSOLE := TRUE;                                                  03172000
   END;                                                                 03174000
END                                                                     03176000
ELSE                                                                    03178000
IF SYSPROC THEN                                                         03180000
BEGIN  << NO DEST SUPPLIED >>                                           03182000
   DEST := ABSOLUTE(CONSOLECELL).(8:8);                                 03184000
   IF CONTROL.(14:2) = 0 THEN CONTROL.(14:2) := 1;                      03186000
      << FORCE SOFT-PREEMPTIVE >>                                       03188000
END                                                                     03190000
ELSE DEST := -2;                                                        03192000
   << CONSOLE FOR SYSTEM PROCESS, $STDLIST OTHERWISE>>                  03194000
                                                                        03196000
IF (CONSOLE OR PMASK.PREPLY) AND CONTROL.(14:2)=0 THEN CONTROL.(14:2)   03198000
   := 1; << FORCE SOFT PREEMPTIVE >>                                    03200000
                                                                        03202000
IF DEST = -2 THEN                                                       03204000
BEGIN << IF $STDLIST, CHECK FOR FUNNYTERM >>                            03206000
   MOVEFROMDSEG(@FUNNYSCR,JMATDST,PXGLOB(JMATX).(0:8)                   03208000
      *JMATENTRYSIZE +24,1); << GET WORD IN JMAT >>                     03210000
   CONTROL.FUNNYTERM := FUNNYSCR.(3:2);  << SET CONTROL>>               03212000
   << FUNNYTERM MAY BE PASSED IN CONTROL, OR >>                         03214000
   << FOUND WHEN LOOKING AT $STDLIST         >>                         03216000
END;                                                                    03218000
                                                                        03220000
<< TAKE CARE OF SETNO >>                                                03222000
                                                                        03224000
IF SETNO = -2 THEN                                                      03226000
BEGIN                                                                   03228000
   SETNO := -1;                                                         03230000
   CONTROL.(0:1) := 1;                                                  03232000
END;                                                                    03234000
                                                                        03236000
<<***** DONE WITH CONTROL *****>>                                       03238000
                                                                        03240000
<<***** SET-UP INPUT BUFF   *****>>                                     03242000
                                                                        03244000
IF SETNO = -1 THEN @INBUFF := MSGNO << SUPPLIED >>                      03246000
ELSE                                                                    03248000
BEGIN                                                                   03250000
   ASSEMBLE(ZERO; LRA S-0);                                             03252000
   @INBUFF := TOS &LSL(1);                                              03254000
   ASSEMBLE(ADDS BUFFSIZEM1);                                           03256000
END;                                                                    03258000
                                                                        03260000
<<***** SET-UP OUTPUT BUFF  *****>>                                     03262000
                                                                        03264000
IF CONSOLE OR PMASK.PREPLY THEN                                         03266000
BEGIN << ALLOCATE OUTPUT BUFFER 'SYSTEM BUFFER' SIZE >>                 03268000
   << BUFFER SIZE LIMITED FOR REPLYS. IF REPLY TOO LONG, >>             03270000
   << PART OF MSG WILL BE LOST FOR =RECALL.              >>             03272000
   ASSEMBLE( ZERO; LRA S-0 );                                           03274000
   @CONSBUFF' := TOS;                                                   03276000
   TOS := RIT'MSGBASE +SBUFSIZEWM1;                            <<04882>>03278000
   ASSEMBLE( ADDS 0 );                                                  03280000
   OUTBUFFSIZE := SBUFSIZE; << SET BUFFSIZE >>                          03282000
   @OUTBUFF' := @CONSBUFF'(RIT'MSGBASE); << BASE OF BUFF >>    <<04882>>03284000
END                                                                     03286000
ELSE                                                                    03288000
BEGIN << ALLOCATE BUFFER 'RECSIZE'. CAN RE-USE BUFF>>                   03290000
   ASSEMBLE(ZERO; LRA S-0);                                             03292000
   @OUTBUFF' := TOS;                                                    03294000
   ASSEMBLE( ADDS BUFFSIZEM1);                                          03296000
   OUTBUFFSIZE := BUFFSIZEB;                                            03298000
END;                                                                    03300000
                                                                        03302000
<<***** PUT IN PREFIX STRING IN OUTPUT BUFF IF CONSOLE***>>             03304000
                                                                        03306000
IF CONSOLE OR PMASK.PREPLY THEN LEN:=CONSPREFIX(PMASK.PREPLY,  <<00552>>03308000
   OUTBUFF');                                                           03310000
                                                                        03312000
<<***** NOW ASSEMBLE MESSAGE   ***** >>                                 03314000
                                                                        03316000
TMP := LEN;                                                    <<04882>>03318000
IF NOT PMASK.PREPLY THEN                                       <<04882>>03320000
     GENMSG :=FORMSG(INBUFF,SETNO,MSGNO,MASK,PARM1,PARM2,PARM3 <<04882>>03322000
          ,PARM4,PARM5,OUTBUFF',OUTBUFFSIZE,LEN,DEST,CONTROL)  <<04882>>03324000
     ELSE GENMSG:=FORMSG(INBUFF,SETNO,MSGNO,MASK,PARM1,PARM2,  <<04882>>03326000
        PARM3,PARM4,PARM5,OUTBUFF',OUTBUFFSIZE,TMP,-1,CONTROL);<<04882>>03328000
<< THE SECOND GENMSG WILL FORMAT INBUF TO BE PUT IN THE RIT >> <<04882>>03330000
<< BUT SINCE FORMSG WILL BE CALLED LATER, THE VARIABLE LEN  >> <<04882>>03332000
<< CANNOT BE CHANGED, SO TMP IS USED. THE DESTINATION IS -1 >> <<04882>>03334000
<< SO THE MESSAGE WILLL NOT BE PRINTED ANYWHERE             >> <<04882>>03336000
     IF < THEN CONDCODE := CCL                                 <<04882>>03338000
          ELSE IF > THEN CONDCODE := CCG;                      <<04882>>03340000
                                                                        03346000
<<***** HANDLE REPLY (MAY BE FOR CONSOLE OR OUTBUFFSIZE)*****>>         03348000
                                                                        03350000
IF PMASK.PREPLY AND CONDCODE <> CCL THEN                       <<04882>>03352000
<< IF NO I/O FAIL, CONSOLE, & REPLY >>                                  03354000
BEGIN                                                                   03356000
   IF NOT PMASK.PDST THEN DST := 0;                                     03358000
                                                               <<00813>>03360000
   << PLACE ENTRY INTO REPLY INFORMATION TABLE >>              <<00813>>03362000
   NOPROBLEM:=PUTRITENTRY(MYPIN,DST,OFFSET,REPLY,TMP           <<04882>>03364000
                ,CONSBUFF');                                   <<04882>>03366000
   IF NOPROBLEM                                                <<04882>>03368000
      THEN GENMSG :=FORMSG(INBUFF,SETNO,MSGNO,MASK,PARM1,PARM2,<<04882>>03370000
                           PARM3,PARM4,PARM5,OUTBUFF',         <<04882>>03372000
                           OUTBUFFSIZE,LEN,DEST,CONTROL)       <<04882>>03374000
      ELSE PENDING := FALSE; << NO ROOM IN TABLE >>            <<04882>>03376000
                                                               <<00813>>03378000
   << WAIT FOR REPLY. WILL AWAKEN WHEN RIT ENTRY DELETED >>    <<00813>>03380000
   IF PENDING THEN WAIT(%40,0); << REPLY IS PENDING >>         <<04882>>03382000
                                                               <<00813>>03384000
   << CHECK SOFT KILL BIT IN PCB TO SEE IF THIS PROCESS IS >>  <<00813>>03386000
   << TO BE ABORTED BUT CAN'T RIGHT NOW BECAUSE IT'S >>        <<00813>>03388000
   << CRITICAL. >>                                             <<00813>>03390000
   IF LOGICAL(ABSOLUTE(ABSOLUTE(CPCB)+9).(11:1))OR NOT PENDING <<04882>>03392000
      THEN                                                     <<04882>>03394000
      << TRYING TO ABORT THIS PROCESS. FAKE AN OPERATOR >>     <<00813>>03396000
      << REPLY OF 0 SO THAT PROCESS WILL EVENTUALLY ABORT. >>  <<00813>>03398000
      IF REPLY.(8:8) = REPLYTYPE'STRINGS OR                    <<00813>>03400000
               REPLY.(8:8) = REPLYTYPE'ONESTRING THEN          <<00813>>03402000
         BEGIN                                                 <<00813>>03404000
         MOVE CHAR'ZERO := ( 1 <<BYTE COUNT>>, "0" );          <<00813>>03406000
         MOVETODSEG(CONSBUFF'(1),CONSBUFF'(2),@CHAR'ZERO,2);   <<00813>>03408000
         CONDCODE := CCL;                                      <<04882>>03410000
         END                                                   <<00813>>03412000
      ELSE BEGIN                                               <<04882>>03414000
         MOVETODSEG(CONSBUFF'(1),CONSBUFF'(2),@ZERO,1);        <<00813>>03416000
         CONDCODE := CCL;                                      <<04882>>03418000
         END;                                                  <<04882>>03420000
END;                                                                    03422000
                                                                        03424000
OUTL:                                                                   03426000
END; << GENMSG >>                                                       03428000
$TITLE "GENMSGU"                                                        03430000
PROCEDURE GENMSGU(A,B);                                                 03432000
   VALUE A,B;INTEGER A,B;                                               03434000
   OPTION PRIVILEGED;                                                   03436000
BEGIN                                                                   03438000
                                                                        03440000
ERRORON;                                                                03442000
GENMSG(A,B);                                                            03444000
ERROREXIT([10/85,6/2],0,0);<< INTRIN#85:EXIT2 >>                        03446000
                                                                        03448000
END; << GENMSGU >>                                                      03450000
$TITLE "CONSPREFIX"                                                     03452000
INTEGER PROCEDURE CONSPREFIX(CONSREPLY,BUFF');                          03454000
   VALUE CONSREPLY;                                                     03456000
   LOGICAL CONSREPLY;                                                   03458000
   ARRAY BUFF';                                                         03460000
   OPTION INTERNAL;                                                     03462000
COMMENT                                                                 03464000
   RETURNS "<TIME>[/#J\SXXX]/<PIN>/"                                    03466000
RETURNS - LENGTH OF PREFIX.                                             03468000
;                                                                       03470000
BEGIN                                                                   03472000
                                                                        03474000
EQUATE JIT = 6;                                                         03476000
                                                                        03478000
INTEGER                                                                 03480000
   INDEX = CONSPREFIX;                                                  03482000
                                                                        03484000
LOGICAL                                                                 03486000
   JOBNUM;                                                              03488000
                                                                        03490000
POINTER PXPTR;                                                          03492000
                                                                        03494000
DOUBLE HRSMIN;                                                          03496000
INTEGER HRS = HRSMIN;                                                   03498000
                                                                        03500000
BYTE ARRAY BUFF(*) = BUFF';                                             03502000
INTRINSIC CLOCK;                                                        03504000
                                                                        03506000
SUBROUTINE DEF'MOVEFROMDSEG;                                            03508000
                                                                        03510000
LOGICAL SUBROUTINE DEF'PXGLOB;                                          03512000
   << CONSOLE PREFIX :                                                  03514000
   <<  [?][H1]H2:MM[/#{J/S}X12[X3-5]]/PN/                               03516000
   >>                                                                   03518000
                                                                        03520000
IF CONSREPLY THEN                                                       03522000
BEGIN                                                                   03524000
   BUFF := "?";                                                         03526000
   INDEX := 1;                                                          03528000
END                                                                     03530000
ELSE INDEX := 0;                                                        03532000
                                                                        03534000
<< GET TIME >>                                                          03536000
                                                                        03538000
HRSMIN := CLOCK;                                                        03540000
INDEX := INDEX +ASCII(HRS.(0:8),10,BUFF(INDEX)); << HOURS >>            03542000
MOVE BUFF(INDEX) := ":00";                                              03544000
INDEX := INDEX +2;                                                      03546000
ASCII(HRS.(8:8),-10,BUFF(INDEX));<< SOLVES 0-9 MIN. PROBLEM >>          03548000
INDEX := INDEX +1;                                                      03550000
                                                                        03552000
   << GET #J/S NUM >>                                                   03554000
                                                                        03556000
IF NOT SYSPROC THEN                                                     03558000
BEGIN << USER PROCESS >>                                                03560000
      << PUT IN #J/S NUMBER >>                                          03562000
   MOVE BUFF(INDEX) := "/#";                                            03564000
   INDEX := INDEX +2;                                                   03566000
   MOVEFROMDSEG(@JOBNUM,PXGLOB(JIT).(6:10),9,1);                        03568000
   BUFF(INDEX) := IF JOBNUM.(0:1) THEN "J" ELSE "S";                    03570000
   INDEX := INDEX +1;                                                   03572000
   INDEX := INDEX +ASCII(JOBNUM.(2:14),10,BUFF(INDEX));                 03574000
END;                                                                    03576000
   BUFF(INDEX) := "/";                                                  03578000
   INDEX := INDEX +1;                                                   03580000
                                                                        03582000
   << ADD IN PIN >>                                                     03584000
INDEX := INDEX +ASCII(MYPIN,10,BUFF(INDEX));                            03586000
BUFF(INDEX) := "/";                                                     03588000
INDEX := INDEX +1;                                                      03590000
                                                                        03592000
   << CONSPREFIX = INDEX >>                                             03594000
                                                                        03596000
END; << CONSPREFIX >>                                                   03598000
                                                                        03600000
$TITLE "INITMSG"                                                        03602000
PROCEDURE INITMSG;                                                      03604000
   OPTION UNCALLABLE;                                                   03606000
COMMENT                                                                 03608000
   THIS PROCEDURE INITIALIZES THE MESSAGE SYSTEM.                       03610000
   - THE DISC ADDRESS OF THE MESSAGE CATALOG IS PUT IN SYS DB.          03612000
   - THE MESSAGE DIRECTORY DATA SEGMENT IS CREATED & STUFFED.           03614000
   - THE MESSAGE DST BUFFER IS OBTAINED AND INITIALIZED.       <<02802>>03616000
RETURNS                                                                 03618000
   CCE = EVERYTHING OK.                                                 03620000
   CCL = SOMETHING WRONG.                                               03622000
;                                                                       03624000
BEGIN                                                                   03626000
                                                                        03628000
ARRAY DIRECTORY(0:MSGDIRSIZE-1);                                        03630000
BYTE ARRAY BUFF(*) = DIRECTORY;                                         03632000
                                                                        03634000
INTEGER                                                                 03636000
   DSTN1,                                                               03638000
   OLDMSGDSTN,                                                 <<00820>>03640000
   SIRN,                                                                03642000
   CATFN,                                                               03644000
   ECODE;                                                               03646000
                                                                        03648000
                                                                        03650000
DOUBLE                                                         <<00820>>03652000
   LABELADR,                                                   <<00820>>03654000
   OLDLABEL;                                                   <<00820>>03656000
LOGICAL                                                                 03658000
   LABELADR1    = LABELADR,                                    <<00820>>03660000
   LABELADR2    = LABELADR +1,                                 <<00820>>03662000
   OLDLABEL1    = OLDLABEL,                                    <<00820>>03664000
   OLDLABEL2    = OLDLABEL +1;                                 <<00820>>03666000
EQUATE                                                         <<00820>>03668000
   FILELABEL'ERROR = 47,                                       <<00820>>03670000
   PURGEOK         = TRUE,                                     <<00820>>03672000
   NOPURGE         = FALSE;                                    <<00820>>03674000
                                                                        03676000
SUBROUTINE ERR(NUM);                                                    03678000
   VALUE NUM;                                                           03680000
   INTEGER NUM;                                                         03682000
BEGIN                                                                   03684000
   CASE NUM OF                                                 <<00820>>03686000
   BEGIN                                                                03688000
   <<0>>BEGIN                                                  <<00820>>03690000
        FCHECK(CATFN,ECODE);                                   <<00820>>03692000
        MOVE BUFF := ("**FILE ERROR ON CATALOG (!)",0);        <<00820>>03694000
        END;                                                   <<00820>>03696000
   <<1>>BEGIN                                                  <<00820>>03698000
        FCHECK(CATFN,ECODE);                                   <<00820>>03700000
        MOVE BUFF := ("**GETDATASEG FAILED ON CATALOG",0);     <<00820>>03702000
        END;                                                   <<00820>>03704000
   <<2>>BEGIN                                                  <<00820>>03706000
        ECODE := FILELABEL'ERROR;                              <<00820>>03708000
        MOVE BUFF := ("**FILE ERROR ON CATALOG (!)",0);        <<00820>>03710000
        END;                                                   <<00820>>03712000
   END;                                                                 03714000
   GENMSG(-1,@BUFF,%10000,ECODE);                                       03716000
   CONDCODE := CCL;                                                     03718000
END; << ERR >>                                                          03720000
                                                                        03722000
SUBROUTINE DEF'MOVETODSEG;                                              03724000
SUBROUTINE GET'MSG'DST;                                        <<02802>>03726000
BEGIN                                                          <<02802>>03728000
                                                               <<02802>>03730000
<<IF MESSAGE DST ALREADY EXISTS, RETURN>>                      <<02802>>03732000
IF IOMSGDST <> 0 THEN                                          <<02802>>03734000
  RETURN;                                                      <<02802>>03736000
                                                               <<02802>>03738000
<< OBTAIN A DST >>                                             <<02802>>03740000
                                                               <<02802>>03742000
                                                               <<02802>>03744000
<< NOW, FIGURE LENGTH OF XDS >>                                <<02802>>03746000
DSTN1:=(SBUFSIZEW * NUM'MSG'BUFS) + 4 <<OVERHEAD>> ;           <<02802>>03748000
                                                               <<02802>>03750000
IOMSGDST := GETDATASEG(DSTN1,DSTN1);                           <<02802>>03752000
IF IOMSGDST = 0 THEN                                           <<02802>>03754000
  RETURN;       <<FAILED TO GET XDS>>                          <<02802>>03756000
                                                               <<02802>>03758000
<< INITIALIZE XDS >>                                           <<02802>>03760000
DIRECTORY := NUM'MSG'BUFS;     <<NUMBER OF MESSAGE BUFFERS>>   <<02802>>03762000
DIRECTORY(1) := SBUFSIZEW;     <<SIZE OF MESSAGE BUFFER>>      <<02802>>03764000
DIRECTORY(2) := 4;             <<POINTER TO FIRST AVAIL>>      <<02802>>03766000
DIRECTORY(3) := (SBUFSIZEW*(NUM'MSG'BUFS-1))+4; << TAIL PTR >> <<02802>>03768000
MOVETODSEG(IOMSGDST,0,@DIRECTORY,4);                           <<02802>>03770000
                                                               <<02802>>03772000
<<LOOP & THREAD POINTERS>>                                     <<02802>>03774000
DSTN1 := 0;            <<LOOP BUFFER INDEX>>                   <<02802>>03776000
ECODE := 4;    <<START DISPLACEMENT OF BUFFERS>>               <<02802>>03778000
WHILE (DSTN1 := DSTN1 + 1) < NUM'MSG'BUFS DO                   <<02802>>03780000
  BEGIN                                                        <<02802>>03782000
  DIRECTORY := ECODE + SBUFSIZEW; <<PTR TO NEXT BUFFER>>       <<02802>>03784000
  MOVETODSEG(IOMSGDST,ECODE,@DIRECTORY,1);                     <<02802>>03786000
  ECODE := ECODE + SBUFSIZEW; <<POINT TO NEXT BUFFER>>         <<02802>>03788000
  END;                                                         <<02802>>03790000
                                                               <<02802>>03792000
<< PLACE ZERO LINK POINTER INTO LAST BUFFER >>                 <<02802>>03794000
DIRECTORY := 0;                                                <<02802>>03796000
MOVETODSEG(IOMSGDST,ECODE,@DIRECTORY,1);                       <<02802>>03798000
END;                                                           <<02802>>03800000
                                                               <<02802>>03802000
                                                                        03804000
GET'MSG'DST;  <<GET & INIT MSG BUFFERS>>                       <<02802>>03806000
                                                               <<02802>>03808000
CONDCODE := CCE;                                                        03810000
                                                                        03812000
<< OPEN MESSAGE CATALOG >>                                              03814000
MOVE BUFF := "CATALOG ";                                                03816000
CATFN := FOPEN(BUFF,5,0); <<OLDPERM,ASCII>>                             03818000
IF <> THEN ERR(0)                                                       03820000
ELSE                                                                    03822000
BEGIN                                                                   03824000
   FGETINFO(CATFN,,,,,,,,,,,,,,,,,,,LABELADR);                          03826000
   IF <> THEN ERR(0)                                                    03828000
   ELSE                                                                 03830000
   BEGIN                                                                03832000
                                                                        03834000
      << READ LABEL & GET MESSAGE DIRECTORY >>                          03836000
      FREADLABEL(CATFN,DIRECTORY,MSGDIRSIZE,0);                         03838000
      IF <> THEN ERR(0)                                                 03840000
      ELSE                                                              03842000
      BEGIN                                                             03844000
                                                                        03846000
         << GET DATA SEGMENT FOR DIRECTORY & MESSAGE BUFFER >>          03848000
         DSTN1 := GETDATASEG(PHYSBLK+MSGDIRSIZE,PHYSBLK+                03850000
            MSGDIRSIZE);                                                03852000
         IF DSTN1 = 0 THEN ERR(1)                                       03854000
         ELSE                                                           03856000
         BEGIN                                                          03858000
                                                                        03860000
            << PUT DIRECTORY IN DATA SEG >>                             03862000
            MOVETODSEG(DSTN1,0,@DIRECTORY,MSGDIRSIZE);                  03864000
                                                               <<00820>>03866000
            << MAKE NEW CATALOG NON-PURGEABLE >>               <<00820>>03868000
            SETLOCKSTATUS(LABELADR,NOPURGE);                   <<00820>>03870000
            IF <> THEN                                         <<00820>>03872000
            BEGIN                                              <<00820>>03874000
              RELDATASEG(DSTN1);                               <<00820>>03876000
              ERR(2);                                          <<00820>>03878000
            END                                                <<00820>>03880000
            ELSE                                               <<00820>>03882000
            BEGIN                                              <<00820>>03884000
                                                               <<00820>>03886000
                                                               <<00820>>03888000
               SIRN := GETSIR(MSGSIR);                         <<00820>>03890000
                                                               <<00820>>03892000
               << SAVE OLD LABEL AND DST >>                    <<00820>>03894000
               OLDLABEL1 := ABSOLUTE(MSGBASE);                 <<00820>>03896000
               OLDLABEL2 := ABSOLUTE(X:=X+1);                  <<00820>>03898000
               OLDMSGDSTN := MSGDSTN;                          <<00820>>03900000
               << STUFF DISC ADDRESS IN SYSDB.      >>         <<00820>>03902000
               << FILE MUST BE 1 EXTENT>>                      <<00820>>03904000
               ABSOLUTE(MSGBASE) := LABELADR1;                 <<00820>>03906000
               ABSOLUTE(X:=X+1) := LABELADR2;                  <<00820>>03908000
                                                               <<00820>>03910000
               << STUFF SYS DB WITH DATSEG NO. >>              <<00820>>03912000
               MSGDSTN:= DSTN1;  << PUT IN SYS DB >>           <<00820>>03914000
                                                               <<00820>>03916000
               RELSIR(MSGSIR,SIRN);                            <<00820>>03918000
                                                               <<00820>>03920000
               << UNLOCK OLD CAT IF ONE EXISTED >>             <<00820>>03922000
               IF OLDMSGDSTN <> 0 THEN                         <<00820>>03924000
                  SETLOCKSTATUS(OLDLABEL,PURGEOK);             <<00820>>03926000
               IF <> THEN                                      <<00820>>03928000
               BEGIN << RESTORE OLD CATALOG >>                 <<00820>>03930000
                  SIRN := GETSIR(MSGSIR);                      <<00820>>03932000
                  ABSOLUTE(MSGBASE) := OLDLABEL1;              <<00820>>03934000
                  ABSOLUTE(X:=X+1) := OLDLABEL2;               <<00820>>03936000
                  MSGDSTN := OLDMSGDSTN;                       <<00820>>03938000
                  RELSIR(MSGSIR,SIRN);                         <<00820>>03940000
                  << RELEASE 'NEW' CAT >>                      <<00820>>03942000
                  RELDATASEG(DSTN1);                           <<00820>>03944000
                  SETLOCKSTATUS(LABELADR,PURGEOK);             <<00820>>03946000
                  ERR(2);                                      <<00820>>03948000
               END;                                            <<00820>>03950000
            END;                                               <<00820>>03952000
         END;                                                  <<00820>>03954000
      END;                                                              03956000
   END;                                                                 03958000
END;                                                                    03960000
OUTL:                                                                   03962000
FCLOSE(CATFN,0,0);                                                      03964000
END; << INITMSG >>                                                      03966000
LOGICAL PROCEDURE REM'QUEUED'ENTRY(PIN);                       <<04882>>03968000
VALUE PIN;                                                     <<04882>>03970000
INTEGER PIN;                                                   <<04882>>03972000
OPTION PRIVILEGED,UNCALLABLE,VARIABLE;                         <<04882>>03974000
<< THIS PROCEDURE REMOVES ENTRIES FROM THE RIT QUEUE.  IF >>   <<04882>>03976000
<< PIN IS PASSED IN THEN THE QUEUE WILL BE CHECKED FOR    >>   <<04882>>03978000
<< THAT SPECIFIC NUMBER AND IF FOUND IT WILL BE DELETED   >>   <<04882>>03980000
<< FROM THE QUEUE AFTER THE PROCESS IS AWAKENED AND A TRUE>>   <<04882>>03982000
<< WILL BE RETURNED.  IF PIN IS NOT PASSED IN THEN THE    >>   <<04882>>03984000
<< FIRST ENTRY IN THE QUEUE WILL BE WOKEN AND REMOVED     >>   <<04882>>03986000
                                                               <<04882>>03988000
BEGIN                                                          <<04882>>03990000
  INTEGER SIRN;                                                <<04882>>03992000
  INTEGER ARRAY RITABLE(*)=DB+0;                               <<04882>>03994000
  LOGICAL PMAP = Q-4;                                          <<04882>>03996000
  INTEGER I;                                                   <<04882>>03998000
  LOGICAL FOUND;                                               <<04882>>04000000
  FOUND := FALSE;                                              <<04882>>04002000
                                                               <<04882>>04004000
  SIRN := GETSIR(RIT'SIR);                                     <<04882>>04006000
  IF RITABLE(QUEUED'ENTRIES) > 0 THEN                          <<04882>>04008000
     BEGIN                                                     <<04882>>04010000
       IF PMAP.(15:1)=0 THEN                                   <<04882>>04012000
          BEGIN                                                <<04882>>04014000
            << NO PIN PASSED IN >>                             <<04882>>04016000
            FOUND := TRUE;                                     <<04882>>04018000
            AWAKE((RITABLE(FIQ))*PCBSIZE,%40,0);               <<04882>>04020000
            RITABLE(QUEUED'ENTRIES):=RITABLE(QUEUED'ENTRIES)-1;<<04882>>04022000
            I:=0;                                              <<04882>>04024000
            WHILE I < RITABLE(QUEUED'ENTRIES) DO               <<04882>>04026000
            BEGIN                                              <<04882>>04028000
              RITABLE(FIQ+I):=RITABLE(FIQ+I+1);                <<04882>>04030000
              I := I+1;                                        <<04882>>04032000
              END;                                             <<04882>>04034000
            RITABLE(LIQ):=RITABLE(LIQ)-1;                      <<04882>>04036000
            END                                                <<04882>>04038000
       ELSE BEGIN                                              <<04882>>04040000
              << PIN WAS PASSED IN >>                          <<04882>>04042000
              I:=0;                                            <<04882>>04044000
            WHILE((NOT FOUND)LAND(I<RITABLE(QUEUED'ENTRIES)))DO<<04882>>04046000
                BEGIN                                          <<04882>>04048000
                  IF PIN = RITABLE(FIQ+I) THEN                 <<04882>>04050000
                     BEGIN                                     <<04882>>04052000
                       FOUND := TRUE;                          <<04882>>04054000
                       AWAKE(PIN*PCBSIZE,%40,0);               <<04882>>04056000
                       RITABLE(QUEUED'ENTRIES):=               <<04882>>04058000
                               RITABLE(QUEUED'ENTRIES)-1;      <<04882>>04060000
                       END;                                    <<04882>>04062000
                 I:=I+1;                                       <<04882>>04064000
                 END; << WHILE DO >>                           <<04882>>04066000
              IF FOUND THEN                                    <<04882>>04068000
                 BEGIN                                         <<04882>>04070000
                   WHILE I <= RITABLE(QUEUED'ENTRIES) DO       <<04882>>04072000
                   BEGIN                                       <<04882>>04074000
                     RITABLE((FIQ+I)-1) := RITABLE(FIQ+I);     <<04882>>04076000
                     I := I+1;                                 <<04882>>04078000
                     END;                                      <<04882>>04080000
                   RITABLE(LIQ):=RITABLE(LIQ)-1;               <<04882>>04082000
                   END;                                        <<04882>>04084000
            END;                                               <<04882>>04086000
       END;<< QUEUED'ENTRIES > 0 >>                            <<04882>>04088000
   REM'QUEUED'ENTRY := FOUND;                                  <<04882>>04090000
   RELSIR(RIT'SIR,SIRN);                                       <<04882>>04092000
   END; << REM'QUEUED'ENTRY >>                                 <<04882>>04094000
$TITLE "REMRITENTRY'"                                          <<01398>>04096000
PROCEDURE REMRITENTRY'(PIN,FLAG);                              <<01398>>04098000
   VALUE PIN, FLAG; INTEGER PIN, FLAG;                         <<01398>>04100000
OPTION UNCALLABLE;                                                      04102000
COMMENT                                                                 04104000
   REMOVES ENTRY FROM THE REPLY INFORMATION TABLE (RIT),                04106000
   THEN PROCESS IS AWAKENED - CONSOLE IS INFORMED.                      04108000
;                                                                       04110000
BEGIN                                                                   04112000
                                                                        04114000
EQUATE JMATSIR = 15;                                           <<01398>>04116000
EQUATE JMATDST = 25;                                           <<01398>>04118000
LOGICAL JMAT'LOGOFF = DB+7;                                    <<01398>>04120000
LOGICAL FOUND;                                                 <<01398>>04122000
INTEGER                                                                 04124000
   INDEX,                                                               04126000
   LIMIT,                                                               04128000
   SAVEDSTN,                                                            04130000
   SIRN;                                                                04132000
                                                                        04134000
                                                                        04136000
INTEGER ARRAY RITABLE(*) = DB+0;                                        04138000
                                                                        04140000
FOUND := FALSE;  <<ASSUME NO RIT ENTRY>>                       <<01398>>04142000
SAVEDSTN := EXCHANGEDB(RIT'DST);                               <<04882>>04144000
SIRN := GETSIR(RIT'SIR);                                       <<04882>>04146000
<< WHIRL THRU TABLE LOOKING FOR PIN IN 1ST WORD>>                       04148000
LIMIT := RIT'HEADSIZE +RITABLE(RIT'HEAD'MAXENT) *RIT'SIZE;     <<04882>>04150000
INDEX := RIT'HEADSIZE -RIT'SIZE;                               <<04882>>04152000
WHILE (INDEX := INDEX +RIT'SIZE) < LIMIT DO                    <<04882>>04154000
   IF RITABLE(INDEX) = PIN THEN                                         04156000
   BEGIN                                                                04158000
      FOUND := TRUE;   <<THERE IS A RIT ENTRY FOR PIN>>        <<01398>>04160000
      RITABLE(INDEX) := 0;                                              04162000
      RITABLE := RITABLE -1; <<DECR. ENTRY COUNT >>                     04164000
      PCB(PIN*PCBSIZE+PCB'ACTORG):=PCB'REPLYDONE;              <<00933>>04166000
      AWAKE(PIN*PCBSIZE,%40,0); <<AWAKE RIT WAIT>>                      04168000
      INDEX := LIMIT; << STOP THIS LOOP >>                              04170000
   END;                                                                 04172000
RELSIR(RIT'SIR,SIRN);                                          <<04882>>04174000
IF FOUND THEN REM'QUEUED'ENTRY << GET NEXT QUEUED ENTRY  >>    <<04882>>04176000
   ELSE IF REM'QUEUED'ENTRY(PIN) THEN GO OUT;                  <<04882>>04178000
   << IF THE PIN WASN'T IN TABLE HE MIGHT HAVE BEEN QUEUED >>  <<04882>>04180000
IF FLAG = 1 AND                                                <<01398>>04182000
   FOUND    AND                                                <<01398>>04184000
   ABSOLUTE(SYSUP) <> 0 THEN                                   <<01398>>04186000
   <<SEND CONSOLE MSG IF REQUESTED (FLAG) AND NOT =SHUTDOWN>>  <<01398>>04188000
   BEGIN                                                       <<01398>>04190000
     EXCHANGEDB(JMATDST);                                      <<01398>>04192000
     SIRN := GETSIR(JMATSIR);                                  <<01398>>04194000
     IF JMAT'LOGOFF.(0:1) <> 1 THEN  <<=LOGOFF IN PROGRESS?>>  <<01398>>04196000
        BEGIN                                                  <<01398>>04198000
           RELSIR(JMATSIR,SIRN);                               <<01398>>04200000
           EXCHANGEDB(0);   <<BACK TO STACK FOR GENMSG>>       <<01398>>04202000
           GENMSG(1,38,%010000,PIN,,,,,0); <<TELL OPERATOR>>   <<01398>>04204000
        END                                                    <<01398>>04206000
      ELSE                                                     <<01398>>04208000
        RELSIR(JMATSIR,SIRN);                                  <<01398>>04210000
   END;                                                        <<01398>>04212000
OUT:                                                           <<04882>>04214000
EXCHANGEDB(SAVEDSTN);                                          <<01398>>04216000
                                                                        04218000
END; << REMRITENTRY >>                                                  04220000
$TITLE "REMRITENTRY"                                           <<01398>>04222000
PROCEDURE REMRITENTRY(PIN);                                    <<01398>>04224000
   VALUE PIN; INTEGER PIN;                                     <<01398>>04226000
   OPTION UNCALLABLE;                                          <<01398>>04228000
COMMENT REMOVES RIT ENTRY WITHOUT SENDING A MSG TO CONSOLE;    <<01398>>04230000
BEGIN                                                          <<01398>>04232000
   REMRITENTRY'(PIN,0);                                        <<01398>>04234000
END;                                                           <<01398>>04236000
                                                                        04238000
$CONTROL SEGMENT=MAIN                                                   04240000
END. << GENMSG >>                                                       04242000
