$CONTROL MAP,CODE,USLINIT                                               00010000
<< USER -- MODULE 83 >>                                        <<00762>>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=USER,MAIN=USER << MODULE 83 >>                         00028000
BEGIN                                                                   00030000
                                                                        00032000
                                                                        00034000
<< ERRORS FOR GENMESSAGE PROCEDURES >>                                  00036000
                                                                        00038000
EQUATE                                                                  00040000
   READLABELFAIL     = 1,                                               00042000
   READFAIL          = 2,                                               00044000
   MISSINGSET        = 3,                                               00046000
   MISSINGMSG        = 4,                                               00048000
   DON'T''USE''THIS  = 5,  << SAME AS 6--DOC ERR KLUGE >>      <<01526>>00050000
   BUFFOVERFLOW      = 6,                                               00052000
   WRITEFAIL         = 7,                                      <<01128>>00054000
   BADFILEOPTIONS    = 8,                                      <<01526>>00056000
                                                                        00058000
   NOFILENOPARM      = 11,                                              00060000
   NOSETNOPARM       = 12,                                              00062000
   NOMSGNOPARM       = 13,                                              00064000
   INVSETNO          = 14,                                              00066000
   SETNOTOOBIG       = 15,                                              00068000
   INVMSGNO          = 16,                                              00070000
   INVBUFFSIZE       = 17,                                              00072000
   INVDESTFILE       = 18,                                              00074000
   ZENDOFERRORS      = 0;                                               00076000
                                                                        00078000
<< SIZES & CELLS FOR GENMESSAGE PROCEDURES >>                           00080000
                                                                        00082000
EQUATE                                                                  00084000
   HEADERSIZE        =  2,                                     <<00762>>00086000
   MAXNOSETS         = 62, <<(SECTOR-HEADER-WORKAREA)/2>>      <<00762>>00088000
   MSGDIRSIZE        = MAXNOSETS*2+HEADERSIZE+2<<WORK AREA>>,  <<00762>>00090000
   MAXSETNOCELL      =  0,                                              00092000
   MAXRECELL         =  1,                                              00094000
   CURRENTRECELL     = MSGDIRSIZE-1,                           <<00762>>00096000
   RECSIZE           = 40,                                              00098000
   RECSIZEB          = RECSIZE*2,                                       00100000
   RECSIZEM1         = RECSIZE -1,                                      00102000
   DATASIZE          = 36,                                              00104000
   DATASIZEB         = 72,                                              00106000
   BLKFACTOR         = 16,                                              00108000
   PHYSBLK           = 16*40,                                           00110000
   SECTORPERBLK      = PHYSBLK/128,                                     00112000
   SETNOTPRESENT     = -1,                                              00114000
                                                                        00116000
   ZENDOFSIZES       = 0;                                               00118000
                                                                        00120000
                                                                        00122000
INTEGER                                                                 00124000
   X = X,                                                               00126000
   S6 = S-6;                                                            00128000
                                                                        00130000
BYTE POINTER                                                            00132000
   BPS0 = S-0;                                                          00134000
                                                                        00136000
DOUBLE POINTER                                                          00138000
   DPS0 = S-0;                                                          00140000
                                                                        00142000
EQUATE                                                                  00144000
   CCG = 0,                                                             00146000
   CCL = 1,                                                             00148000
   CCE = 2;                                                             00150000
                                                                        00152000
LOGICAL                                                                 00154000
   STATUS = Q-1;                                                        00156000
                                                                        00158000
DEFINE                                                                  00160000
   CONDCODE = STATUS.(6:2)#;                                            00162000
                                                                        00164000
DEFINE                                                                  00166000
   CCGRETN       = BEGIN                                                00168000
                      CONDCODE := CCG;                                  00170000
                      GO OUTL;                                          00172000
                   END#,                                                00174000
   CCLRETN       = BEGIN                                                00176000
                      CONDCODE := CCL;                                  00178000
                      GO OUTL;                                          00180000
                   END#,                                                00182000
   ZENDOFDEFINES = 0#;                                                  00184000
                                                                        00186000
                                                                        00188000
INTRINSIC WHO,ASCII,BINARY,CLOCK,CALENDAR,DASCII,PRINT,                 00190000
   FWRITE,FREADDIR,FREADLABEL;                                          00192000
                                                                        00194000
INTEGER PROCEDURE GETNUM(PTR,NUM); VALUE PTR;                           00196000
   BYTE POINTER PTR;INTEGER NUM;OPTION FORWARD;                         00198000
                                                                        00200000
   << FORWARDS >>                                                       00202000
                                                                        00204000
                                                                        00206000
PROCEDURE FMTDATE(CALENDAR',CLOCK',STRING);                             00208000
   VALUE CALENDAR',CLOCK';                                              00210000
   LOGICAL CALENDAR';                                                   00212000
   DOUBLE CLOCK';                                                       00214000
   BYTE ARRAY STRING;                                                   00216000
   OPTION FORWARD;                                                      00218000
                                                                        00220000
PROCEDURE LENBUF(BUFF,LEN,CRLF,RECNO);                                  00222000
   BYTE ARRAY BUFF;                                                     00224000
  INTEGER LEN;                                                 <<02339>>00226000
  DOUBLE RECNO;                                                <<02339>>00228000
   LOGICAL CRLF;                                                        00230000
   OPTION FORWARD;                                                      00232000
                                                                        00234000
PROCEDURE READCAT(FILENO,RECNO,CURRENTREC,BLOCKBUFF',                   00236000
      BUFFPTR);                                                         00238000
   VALUE FILENO,RECNO;                                                  00240000
   INTEGER FILENO,CURRENTREC;                                  <<02339>>00242000
   DOUBLE RECNO;                                               <<02339>>00244000
   ARRAY BLOCKBUFF';                                                    00246000
   BYTE POINTER BUFFPTR;                                                00248000
   OPTION FORWARD;                                                      00250000
                                                                        00252000
                                                                        00254000
$TITLE "CONVERTDATE"                                                    00256000
LOGICAL PROCEDURE CONVERTDATE(PTR);                                     00258000
   VALUE PTR;                                                           00260000
   BYTE POINTER PTR;                                                    00262000
COMMENT                                                                 00264000
   CONVERTS STRING CONTAINING "MM/DD/YY" INTO A WORD OF THE             00266000
   FOLLOWING FORMAT:                                                    00268000
            CONVERTDATE.(0:7) = YEAR                                    00270000
            CONVERTDATE.(7:9) = DAY OF YEAR                             00272000
   STRING MUST BE TERMINATED BY NON-NUMERIC. ERROR RETURNS CCG.         00274000
   DATE ARRAY MAY CONTAIN LEADING BLANKS AS WELL AS BLANKS              00276000
   BETWEEN SLASHES. ANY SPECIAL CAN BE USED INSTEAD OF "/"              00278000
;                                                                       00280000
BEGIN                                                                   00282000
                                                                        00284000
EQUATE                                                                  00286000
   CCG = 0,                                                             00288000
   CCE = 2;                                                             00290000
                                                                        00292000
LOGICAL STATUS = Q-1;                                                   00294000
                                                                        00296000
INTEGER                                                                 00298000
   MONTH,                                                               00300000
   DAY,                                                                 00302000
   YEAR;                                                                00304000
INTEGER ARRAY FIRSTDAY(*) = PB :=                                       00306000
   0,31,59,90,120,151,181,212,243,273,304,334;                          00308000
INTEGER ARRAY DAYSINMONTH(*) = PB :=                                    00310000
   31,28,31,30,31,30,31,31,30,31,30,31;                                 00312000
                                                                        00314000
STATUS.(6:2) := CCG; << SET BAD >>                                      00316000
@PTR := GETNUM(PTR,MONTH);                                              00318000
IF = AND PTR = "/" THEN                                                 00320000
BEGIN                                                                   00322000
   @PTR := GETNUM(PTR(1),DAY);                                          00324000
   IF = AND PTR = "/" THEN                                              00326000
   BEGIN                                                                00328000
      GETNUM(PTR(1),YEAR);                                              00330000
      IF = AND (1<= MONTH <= 12) AND (1<= DAY <= 31)                    00332000
         AND ( 1 <= YEAR <= 99 ) THEN                          <<01505>>00334000
      BEGIN << RANGE ON MONTH,DAY,YEAR OK >>                            00336000
         IF DAY <= DAYSINMONTH(MONTH -1) +(IF YEAR MOD 4 =              00338000
            0 AND MONTH = 2 THEN 1 ELSE 0) THEN                         00340000
         BEGIN  << VALID NO. DAYS IN MONTH>>                            00342000
            TOS := DAY +FIRSTDAY(MONTH -1) +(IF YEAR MOD 4 =            00344000
               0 AND MONTH > 2 THEN 1 ELSE 0);                          00346000
            TOS.(0:7) := YEAR;                                          00348000
            CONVERTDATE := TOS;                                         00350000
            STATUS.(6:2) := CCE; << PEACHY >>                           00352000
         END;                                                           00354000
      END;                                                              00356000
   END;                                                                 00358000
END;                                                                    00360000
                                                                        00362000
END; << CONVERTDATE >>                                                  00364000
$TITLE "CONVERTTIME"                                                    00366000
DOUBLE PROCEDURE CONVERTTIME(PTR);                                      00368000
   VALUE PTR;                                                           00370000
   BYTE POINTER PTR;                                                    00372000
COMMENT                                                                 00374000
   CONVERTS BUFF CONTAINING "HH:MM" INTO DOUBLE IN                      00376000
   MILLISECONDS. ERROR RETURNS CCG. BUFF MAY CONTAINS BLANKS.           00378000
;                                                                       00380000
BEGIN                                                                   00382000
                                                                        00384000
EQUATE                                                                  00386000
   CCG = 0,                                                             00388000
   CCE = 2;                                                             00390000
                                                                        00392000
INTEGER                                                                 00394000
   HOUR,                                                                00396000
   MIN,                                                                 00398000
   STATUS = Q-1;                                                        00400000
                                                                        00402000
STATUS.(6:2) := CCG; << SET BAD >>                                      00404000
@PTR := GETNUM(PTR,HOUR);                                               00406000
IF = AND PTR = ":" THEN                                                 00408000
BEGIN                                                                   00410000
   GETNUM(PTR(1),MIN);                                                  00412000
   IF = AND (0 <= HOUR <= 23) AND (0 <= MIN <= 59) THEN                 00414000
   BEGIN                                                                00416000
      TOS := 60 *HOUR +MIN;                                             00418000
      TOS := 60000;                                                     00420000
      ASSEMBLE(LMPY);                                                   00422000
      CONVERTTIME := TOS;                                               00424000
      STATUS.(6:2) := CCE; << PEACHY >>                                 00426000
   END;                                                                 00428000
END;                                                                    00430000
                                                                        00432000
END; << CONVERTTIME >>                                                  00434000
$TITLE "DATE'LINE"                                                      00436000
PROCEDURE DATE'LINE(STRING);                                            00438000
   BYTE ARRAY STRING;                                                   00440000
COMMENT USES CLOCK & CALENDAR TO CREATE 27 CHARACTER STRING             00442000
   IN THE FOLLOWING FORMAT:                                             00444000
      "THU, JAN 13, 1977, 10:03 AM"                                     00446000
   STRING(27) CONTAINS A ZERO TO TERMINATE STRING.                      00448000
;                                                                       00450000
BEGIN                                                                   00452000
                                                                        00454000
FMTDATE(CALENDAR,CLOCK,STRING);                                         00456000
STRING(27):=0;                                                 <<02338>>00458000
                                                                        00460000
END; << DATE'LINE >>                                                    00462000
$TITLE "DEBLANK"                                                        00464000
INTEGER PROCEDURE DEBLANK(BUFF,WIDTH);                                  00466000
   VALUE WIDTH; INTEGER WIDTH;                                          00468000
   BYTE ARRAY BUFF;                                                     00470000
COMMENT                                                                 00472000
   DEBLANKS ON RIGHT                                                    00474000
;                                                                       00476000
BEGIN                                                                   00478000
                                                                        00480000
X := WIDTH -1;                                                          00482000
IF BUFF(X) <> " " THEN DEBLANK := WIDTH                                 00484000
ELSE                                                                    00486000
BEGIN                                                                   00488000
   TOS := @BUFF(X);                                                     00490000
   ASSEMBLE(DUP,DECA);                                                  00492000
   TOS := -X;                                                           00494000
   ASSEMBLE(CMPB 0);                                                    00496000
   DEBLANK := -TOS;                                                     00498000
   DDEL;                                                                00500000
END;                                                                    00502000
                                                                        00504000
END; << DEBLANK >>                                                      00506000
$TITLE "FINDMSG"                                                        00508000
DOUBLE PROCEDURE FINDMSG(DIRECTORY,FILENO,SETNO,MSGNO,         <<02339>>00510000
      BLOCKBUFF',BUFFPTR,LEN,CRLF,ERRNO);                               00512000
   VALUE FILENO,SETNO,MSGNO;                                            00514000
   INTEGER FILENO,SETNO,MSGNO,LEN,ERRNO;                                00516000
   ARRAY DIRECTORY,BLOCKBUFF';                                          00518000
   BYTE POINTER BUFFPTR;                                                00520000
   LOGICAL CRLF;                                                        00522000
   OPTION INTERNAL;                                                     00524000
COMMENT                                                                 00526000
   FETCHES ONE LINE OF MESSAGE FROM MSG CATALOG. TRANSFORMS             00528000
   SETNO & MSGNO INTO RECORD NUMBER & CALLS READCAT TO GET              00530000
   MSG.  REC NO. IS CALCULATED BY FINDING STARTING RECORD               00532000
   NUMBER OF FIRST MESSAGE IN DIRECTORY & ADDING IN THE                 00534000
   DIFFERENCE BETWEEN MSGNO & FIRST MSG NO. IN CATALOG                  00536000
   (ALSO IN DIRECTORY). IF THE MSG FOUND IN THE CATALOG                 00538000
   IS NOT THE ONE DESIRED, A BINARY SEARCH IS THEN DONE.                00540000
   BUFF' MUST BE AT LEAST AS LARGE AS RECORD SIZE.                      00542000
PARAMETERS                                                              00544000
   SETNO  = SETNO FROM GENMSG.                                          00546000
   MSGNO  = MSGNO FROM GENMSG.                                          00548000
   BUFF'  = ARRAY FOR MESSAGE. MUST BE "BUFFSIZE".                      00550000
   LEN    = LENGTH OF MESSAGE IN POSITIVE BYTES.                        00552000
   CRLF   = %320 CONTINUE WITH NO CRLF.                                 00554000
          = 0 CONTINUE NEXT MSG. AFTER CRLF.                            00556000
RETURNS                                                                 00558000
   - LEN IS THE LENGTH OF THE MESSAGE.                                  00560000
   - FINDMSG IS THE RECORD NUMBER OF THE CONTINUED MSG. 0               00562000
     INDICATES NO CONTINUATION.                                         00564000
   - CCL File system error.                                             00566000
   - CCG Non-existent set or message.                                   00568000
;                                                                       00570000
BEGIN                                                                   00572000
   INTEGER ARRAY RECNO'ARRAY(0:2)=Q;                                    00574000
   INTEGER ARRAY HEAD'ARRAY(0:1) =Q;                                    00576000
                                                                        00578000
   INTEGER                                                              00580000
      MAXSETNO = HEAD'ARRAY,    << MAXSETNOCELL >>                      00584000
      NUMRECS  = HEAD'ARRAY +1, << MAXRECELL >>                         00586000
      MSGNOLEN = MAXSETNO;      <<MAXSETNO OVERLAID>>          <<02339>>00588000
                                                                        00592000
   INTEGER                                                              00594000
      VECTOR;                                                           00596000
                                                                        00598000
   DOUBLE                                                      <<02339>>00600000
      RECNO'LO,                << SET'ROFFSET >>               <<02339>>00602000
      RECNO,                   << SET'FIRSTMSG >>              <<02339>>00604000
      RECNO'HI,                << NEXT'SET'ROFFSET >>          <<02339>>00606000
      RECBND,                                                  <<02339>>00608000
      DUMRECNO,                                                <<02339>>00610000
      RECNO'NEW;                                               <<02339>>00612000
                                                                        00614000
                                                                        00616000
INTEGER SUBROUTINE CHKMSGNO(RECTEST);                                   00618000
   VALUE RECTEST;                                                       00620000
   DOUBLE RECTEST;                                             <<02339>>00622000
COMMENT                                                                 00624000
   READS CATALOG & CHECKS TO SEE IF LINE CONTAINS MESSAGE NO.           00626000
   SETS MSGNOLEN.                                                       00628000
;                                                                       00630000
BEGIN                                                                   00632000
      << TEST RECNO LIMITS.MISSING MSGNO WILL FAIL, SINCE >>            00634000
      << LO & HI LIMITS CONTRACT >>                                     00636000
                                                                        00638000
IF (RECTEST >= RECNO'LO) AND (RECTEST <= RECNO'HI) THEN        <<02339>>00640000
      BEGIN                                                             00642000
         READCAT(FILENO,RECTEST,DIRECTORY(CURRENTRECELL),               00644000
            BLOCKBUFF',BUFFPTR);                                        00646000
         IF < THEN                                             <<01128>>00648000
         BEGIN                                                          00650000
            ERRNO := READFAIL;                                          00652000
            CCLRETN;                                                    00654000
         END;                                                           00656000
      END                                                               00658000
      ELSE                                                              00660000
      BEGIN                                                             00662000
         ERRNO := MISSINGMSG;                                           00664000
         CCGRETN;                                                       00666000
      END;                                                              00668000
                                                                        00670000
      << NOW FIND MSGNO IN MSG >>                                       00672000
                                                                        00674000
      << EXTRACT MSGNO LEN FOR BINARY >>                                00676000
      TOS := @BUFFPTR;                                                  00678000
      ASSEMBLE(DUP,DUP);                                                00680000
      MOVE * := * WHILE N,1;                                            00682000
      ASSEMBLE(LSUB,NEG);                                      <<00872>>00684000
      MSGNOLEN := TOS;                                         <<00872>>00686000
                                                               <<01321>>00688000
   << MAKE SURE CURRENT LINE ISN'T A CONTINUATION LINE. >>     <<01321>>00690000
      IF MSGNOLEN <> 0  AND  RECTEST > RECNO'LO  THEN          <<01321>>00692000
      BEGIN                                                    <<01321>>00694000
                                                               <<01321>>00696000
         DUMRECNO := RECTEST - 1D;                             <<02339>>00698000
         READCAT( FILENO, DUMRECNO, DIRECTORY(CURRENTRECELL),  <<01321>>00700000
                  BLOCKBUFF', BUFFPTR );                       <<01321>>00702000
         IF < THEN                                             <<01321>>00704000
         BEGIN                                                 <<01321>>00706000
            ERRNO := READFAIL;                                 <<01321>>00708000
            CCLRETN;                                           <<01321>>00710000
         END;                                                  <<01321>>00712000
         LENBUF( BUFFPTR, LEN, CRLF, DUMRECNO );               <<01321>>00714000
         IF DUMRECNO = 0D  THEN                                <<02339>>00716000
         BEGIN                                                 <<01321>>00718000
            READCAT(FILENO,RECTEST,DIRECTORY(CURRENTRECELL),   <<01321>>00720000
                     BLOCKBUFF', BUFFPTR );                    <<01321>>00722000
            IF < THEN                                          <<01321>>00724000
            BEGIN                                              <<01321>>00726000
               ERRNO := READFAIL;                              <<01321>>00728000
               CCLRETN;                                        <<01321>>00730000
            END;                                               <<01321>>00732000
         END                                                   <<01321>>00734000
         ELSE MSGNOLEN := 0;                                   <<01321>>00736000
                                                               <<01321>>00738000
      END;                                                     <<01321>>00740000
                                                               <<01321>>00742000
      CHKMSGNO := MSGNOLEN;                                             00744000
END; << CHKMSGNO >>                                                     00746000
                                                                        00748000
   << PROCEDURE MAIN BODY >>                                            00750000
                                                                        00752000
CONDCODE := CCE;                                                        00754000
VECTOR := 1; << MOVE FORWARD INITIALLY >>                               00756000
                                                                        00758000
                                                                        00760000
   << GET MAXSETNO,NUMRECS FROM DIRECTORY >>                            00762000
MOVE HEAD'ARRAY := DIRECTORY,(2);                                       00764000
                                                                        00766000
                                                                        00768000
   << GET SET'ROFFSET,SET'FIRSTMSG,NEXT'SET'ROFFSET >>                  00770000
MOVE RECNO'ARRAY := DIRECTORY(SETNO*2),(3);                             00772000
                                                                        00774000
   << RECNO'LO = SET'ROFFSET >>                                         00776000
   << RECNO    = SET'FIRSTMSG >>                                        00778000
   << RECNO'HI = NEXT'SET'ROFFSET >>                                    00780000
                                                               <<02339>>00782000
RECNO'LO := DOUBLE(RECNO'ARRAY);                               <<02339>>00784000
RECNO := DOUBLE(RECNO'ARRAY(1));                               <<02339>>00786000
RECNO'HI := DOUBLE(RECNO'ARRAY(2));                            <<02339>>00788000
RECBND := DOUBLE(NUMRECS);                                     <<02339>>00790000
                                                               <<02339>>00792000
IF (SETNO > MAXSETNO) OR (RECNO = DOUBLE(SETNOTPRESENT)) THEN  <<02339>>00794000
BEGIN << SET NOT PRESENT >>                                             00796000
   ERRNO := MISSINGSET;                                                 00798000
   CCGRETN;                                                             00800000
END;                                                                    00802000
                                                                        00804000
   << SET BOUNDS ON REC. NO. FOR THIS SET >>                            00806000
RECNO'HI := IF SETNO=MAXSETNO  THEN DOUBLE(NUMRECS)            <<02339>>00808000
   ELSE  RECNO'HI - 1D;                                        <<02339>>00810000
                                                                        00812000
<< SET RECNO FOR SETNO,MSGNO >>                                         00814000
RECNO := RECNO'LO + DOUBLE(MSGNO) - RECNO;                     <<02339>>00816000
<< SET'ROFFSET +MSGNO -SET'FIRSTMSG >>                                  00818000
IF RECNO >= RECNO'HI THEN << SET AT UPPER BOUNDS >>                     00820000
BEGIN                                                                   00822000
   RECNO := RECNO'HI;                                                   00824000
   VECTOR := -1;                                                        00826000
END;                                                                    00828000
                                                                        00830000
RECBND := -1D;   << FORCES CHKMSGNO CALL 1ST TIME THRU >>      <<02339>>00832000
   << SEARCH FOR CORRECT MSGNO LOOP >>                                  00834000
                                                                        00836000
WHILE TRUE DO                                                           00838000
BEGIN                                                                   00840000
   IF RECBND <> RECNO THEN << GO FETCH A NEW MESSAGE >>                 00842000
      WHILE CHKMSGNO(RECNO) = 0  DO RECNO := RECNO -1D;        <<02339>>00844000
         << IF REC DOESN'T HAVE MSGNO, GO BACKWARDS >>                  00846000
         << NOW HAVE REC CONTAINING MSGNO, FIND IF CORRECT>>            00848000
      TOS := BINARY(BUFFPTR,MSGNOLEN); <<SET IN CHKMSGNO>>              00850000
      TOS := TOS -MSGNO; DEL;                                           00852000
      IF = THEN << FETCHED CORRECT MSG >>                               00854000
      BEGIN << MOVE MSG OVER MSGNO & ADJUST LEN >>                      00856000
                                                                        00858000
            << NOW FIND END OF MSG & IF CONT'D. >>                      00860000
         LENBUF(BUFFPTR,LEN,CRLF,RECNO);                                00862000
         FINDMSG := RECNO;                                              00864000
                                                                        00866000
         LEN := LEN-(MSGNOLEN +1);                                      00868000
         IF LEN < 0 THEN LEN := 0;  << NULL LINE >>            <<01213>>00870000
            << MOVE MSG OVER MSGNO        >>                            00872000
            << MESSAGE STARTS 1 PAST MSGNO>>                            00874000
         MOVE BUFFPTR := BUFFPTR(MSGNOLEN +1),(LEN);                    00876000
                                                                        00878000
         GO OUTL; << ONLY SUCCESSFUL EXIT >>                            00880000
                                                                        00882000
      END;                                                              00884000
                                                                        00886000
         << DIDN'T FIND MSG. NO. NOW BINARY SEARCH >>                   00888000
      IF < THEN VECTOR := +1 ELSE VECTOR := -1;                         00890000
         << IF MSGNO LO, THEN +1.IF HI, THEN -1 >>                      00892000
      RECNO'NEW := (RECNO + DOUBLE(RECNO'ARRAY(1+VECTOR)))/2D; <<02339>>00894000
      << SET BOUND AT RECORD WITH MSGNO >>                              00896000
      RECBND := RECNO;                                                  00898000
         << BOUNDARY RECORD MUST BE A RECORD CONTAINING A >>            00900000
         << MESSAGE NO. RECBND WILL BE EITHER NEW HI OR LO>>            00902000
      DO RECBND := RECBND + DOUBLE(VECTOR)                     <<02339>>00904000
         UNTIL CHKMSGNO(RECBND) <> 0;                          <<02339>>00906000
      RECNO'ARRAY(1-VECTOR):=INTEGER(RECBND);<<NEW HI OR LO>>  <<02339>>00908000
      <<VECTOR=1 THEN WANT RECNO'LO; IF -1 THEN RECNO'HI>>     <<02339>>00910000
      IF VECTOR=1 THEN RECNO'LO:=DOUBLE(RECNO'ARRAY(1-VECTOR)) <<02339>>00912000
       ELSE RECNO'HI:=DOUBLE(RECNO'ARRAY(1-VECTOR));           <<02339>>00914000
                                                               <<02339>>00916000
      RECNO := IF RECNO=RECNO'NEW  THEN RECNO + DOUBLE(VECTOR) <<02339>>00918000
         ELSE IF (RECNO'NEW >= RECNO'LO) AND                   <<02339>>00920000
                 (RECNO'NEW <= RECNO'HI) THEN RECNO'NEW        <<02339>>00922000
              ELSE DOUBLE(RECNO'ARRAY(1-VECTOR));              <<02339>>00924000
                                                                        00926000
       << IF NEW SAME AS OLD, BUMP. IF NEW FALLS OUT OF>>               00928000
       << LIMITS BECAUSE OF MULTIPLE LINES/MSG SET AT  >>               00930000
       << NEW BOUND                                    >>               00932000
                                                                        00934000
END; << FIND MSGNO LOOP >>                                              00936000
                                                                        00938000
OUTL:                                                                   00940000
END; << FINDMSG >>                                                      00942000
$TITLE "FMTCLOCK"                                                       00944000
PROCEDURE FMTCLOCK(CLOCK',STRING);                                      00946000
   VALUE CLOCK';                                                        00948000
   DOUBLE CLOCK';                                                       00950000
   BYTE ARRAY STRING;                                                   00952000
COMMENT USES CLOCK' TO CREATE AN 8 CHARACTER STRING IN THE              00954000
   FOLLOWING FORMAT:                                                    00956000
      "10:03 AM"                                                        00958000
;                                                                       00960000
BEGIN                                                                   00962000
                                                                        00964000
INTEGER                                                                 00966000
   TIME = CLOCK',                                                       00968000
   HOUR;                                                                00970000
                                                                        00972000
EQUATE NOON = 12*256;                                                   00974000
                                                                        00976000
   SUBROUTINE  CONVERT(N, POSITION);                                    00978000
      VALUE  N, POSITION;  INTEGER N, POSITION;                         00980000
      BEGIN                                                             00982000
COMMENT CONVERT N TO 2-DIGIT ASCII AT STRING(POSITION). ;               00984000
         X := POSITION;  TOS := N;  << GET PARAMETERS >>                00986000
         ASSEMBLE( LDI 10;  DIV,XCH ); << GET TWO DIGITS >>             00988000
         STRING(X) := TOS+"0";  X := X+1;  STRING(X) :=                 00990000
            TOS +"0";                                                   00992000
      END;  << CONVERT >>                                               00994000
                                                                        00996000
MOVE STRING := " H:MM AM";                                              00998000
<< DO HOURS >>                                                          01000000
HOUR := (TIME.(0:8) +11) MOD 12 +1;                                     01002000
IF HOUR < 10 THEN STRING(1) := HOUR + "0"                               01004000
ELSE CONVERT(HOUR,0);                                                   01006000
<< DO MINUTES >>                                                        01008000
CONVERT(TIME.(8:8),3);                                                  01010000
<< DO AM/PM >>                                                          01012000
IF TIME >= NOON THEN STRING(6) := "P";                                  01014000
                                                                        01016000
END; << FMTCLOCK >>                                                     01018000
$TITLE "FMTCALENDAR"                                                    01020000
PROCEDURE FMTCALENDAR(CALENDAR',STRING);                                01022000
   VALUE CALENDAR';                                                     01024000
   LOGICAL CALENDAR';                                                   01026000
   BYTE ARRAY STRING;                                                   01028000
COMMENT USES CALENDAR' TO CREATE A 17 CHARACTER STRING IN THE           01030000
   FOLLOWING FORMAT:                                                    01032000
      "THU, JAN 13, 1977"                                               01034000
;                                                                       01036000
BEGIN                                                                   01038000
                                                                        01040000
INTEGER                                                                 01042000
   YEAR,                                                                01044000
   DAY;                                                                 01046000
                                                                        01048000
   BYTE ARRAY  DAYS(0:20)=PB := "SUNMONTUEWEDTHUFRISAT";                01050000
   BYTE ARRAY  MONTHS(0:35)=PB :="JANFEBMARAPRMAYJUNJULAUG",            01052000
      "SEPOCTNOVDEC";                                                   01054000
   INTEGER ARRAY  DAYSPERMONTH(0:11)=PB :=                              01056000
     0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335;             01058000
                                                                        01060000
   SUBROUTINE  CONVERT(N, POSITION);                                    01062000
      VALUE  N, POSITION;  INTEGER N, POSITION;                         01064000
      BEGIN                                                             01066000
      COMMENT  CONVERT N TO 2-DIGIT ASCII AT STRING(POSITION).          01068000
;                                                                       01070000
         X := POSITION;  TOS := N;  << GET PARAMETERS >>                01072000
         ASSEMBLE( LDI 10;  DIV,XCH ); << GET TWO DIGITS >>             01074000
         STRING(X) := TOS+"0";  X := X+1;  STRING(X) :=                 01076000
            TOS +"0";                                                   01078000
      END;  << CONVERT >>                                               01080000
                                                                        01082000
YEAR := CALENDAR'.(0:7);                                                01084000
DAY := CALENDAR'.(7:9);                                                 01086000
<< DAY OF WEEK >>                                                       01088000
X := ((YEAR -1) &ASR(2) +YEAR +DAY) MOD 7 *3;                           01090000
MOVE STRING := DAYS(X),(3),2;                                           01092000
MOVE * := ", MMM  D, 19YY";                                             01094000
<< LEAP YEAR >>                                                         01096000
IF (YEAR.(14:2) <> 0 OR YEAR = 0) AND DAY >= 60                <<04499>>01098000
   THEN DAY := DAY + 1;                                        <<04499>>01100000
<< MONTH >>                                                             01102000
TOS := @STRING(5);                                                      01104000
X := 12; << ADDRESS FOR MONTH >>                                        01106000
DO X := X-1 UNTIL DAYSPERMONTH(X) < DAY; <<FIND THE MONTH>>             01108000
DAY := DAY - DAYSPERMONTH(X); << X IS MONTH >>                          01110000
MOVE * := MONTHS(X*3),(3); << NAME OF MONTH >>                          01112000
<< DO DAY >>                                                            01114000
IF DAY < 10 THEN STRING(10) := DAY + "0"                                01116000
ELSE CONVERT(DAY,9);                                                    01118000
<< DO YEAR >>                                                           01120000
CONVERT(YEAR,15);                                                       01122000
                                                                        01124000
END; << FMTCALENDAR >>                                                  01126000
$TITLE "FMTDATE"                                                        01128000
PROCEDURE FMTDATE(CALENDAR',CLOCK',STRING);                             01130000
   VALUE CALENDAR',CLOCK';                                              01132000
   LOGICAL CALENDAR';                                                   01134000
   DOUBLE CLOCK';                                                       01136000
   BYTE ARRAY STRING;                                                   01138000
BEGIN                                                                   01140000
                                                                        01142000
FMTCALENDAR(CALENDAR',STRING);                                          01144000
MOVE STRING(17) := ", "; << COMMA AFTER DAY,MONTH,YEAR >>               01146000
FMTCLOCK(CLOCK',STRING(19));                                            01148000
                                                                        01152000
END; << FMTDATE >>                                                      01154000
$TITLE "FORMNAME"                                                       01156000
INTEGER PROCEDURE FORMNAME(TYPE,TARGET,BA1,BA2,BA3,BA4);                01158000
   VALUE TYPE;INTEGER TYPE;                                             01160000
   BYTE ARRAY TARGET,BA1,BA2,BA3,BA4;                                   01162000
COMMENT                                                                 01164000
   COMPACTS NAMES & SEPARATES THEM WITH COMMAS AND PERIODS.             01166000
   NAMES MUST BE LEFT JUSTIFIED & TERMINATED BY ANY NON-                01168000
   ALPHANUMERIC. ALL FOUR ARRAYS ARE REQUIRED ALTHOUGH ONLY             01170000
   THOSE FORMATTED ARE LOOKED AT. NAMES ARE FORMATTED ACCORD-           01172000
   ING TO TYPE:                                                         01174000
                                                                        01176000
   TYPE   BA1  BA2   BA3   BA4                                          01178000
     1  FILEN.GROUP.ACCTN                                               01180000
     2  [JBN,]USERN.ACCTN                                               01182000
     3  [JBN,]USERN.ACCTN,GROUP                                         01184000
     4  USERN.ACCTN                                                     01186000
     5  {J/S}nnn USERN.ACCTN                                   <<U.RAO>>01188000
                                                                        01190000
   LENGTH IS RETURNED. ALSO TARGET IS TERMINATED BY 0.                  01192000
   IF AN ARRAY IS ALL BLANK, ITS TRAILING DELIM WILL BE                 01194000
   OMITTED.                                                             01196000
;                                                                       01198000
BEGIN                                                                   01200000
                                                                        01202000
BYTE POINTER BPS0 = S-0;                                                01204000
ARRAY NAMEA(*) = TYPE+2;                                                01206000
INTEGER                                                                 01208000
   INDEX,                                                               01210000
   TLEN = INDEX;                                                        01212000
BYTE ARRAY DELIM(0:3);                                                  01214000
                                                                        01216000
DELIM := 0; <<STOPPER IF TYPE BAD >>                                    01218000
CASE TYPE-1 OF                                                          01220000
BEGIN                                                                   01222000
   BEGIN << TYPE 1 >>                                                   01224000
      MOVE DELIM := ("..",0);                                           01226000
      TLEN := 26;                                                       01228000
   END;                                                                 01230000
   BEGIN << TYPE 2 >>                                                   01232000
      MOVE DELIM := (",.",0);                                           01234000
      TLEN := 26;                                                       01236000
   END;                                                                 01238000
   BEGIN << TYPE 3 >>                                                   01240000
      MOVE DELIM := (",.,",0);                                          01242000
      TLEN := 35;                                                       01244000
   END;                                                                 01246000
   BEGIN << TYPE 4 >>                                                   01248000
      MOVE DELIM := (".",0);                                            01250000
      TLEN := 17;                                                       01252000
   END;                                                                 01254000
   BEGIN  <<TYPE 5>>                                           <<U.RAO>>01256000
      MOVE DELIM := (" .",0);                                  <<U.RAO>>01258000
      TLEN := 24;   <<7 FOR J/S NUMBER, 17 FOR USER.ACCT>>     <<U.RAO>>01260000
   END;                                                        <<U.RAO>>01262000
END;                                                                    01264000
TARGET := 0;                                                            01266000
MOVE TARGET(1) := TARGET,(TLEN);                                        01268000
INDEX := -1;                                                            01270000
TOS := @TARGET;                                                         01272000
ASSEMBLE(DUP);                                                          01274000
                                                                        01276000
DO BEGIN << MOVE EACH ARRAY, FIND END,ADD DELIM >>                      01278000
   INDEX := INDEX +1;                                                   01280000
   TOS := NAMEA(INDEX);                                                 01282000
   MOVE * := * ,(8); <<MOVE INPUT NAME>>                                01284000
   MOVE BPS0 := BPS0 WHILE AN,1; << FIND END >>                         01286000
   ASSEMBLE(DUP, STAX); << SAVE END ADR >>                              01288000
   IF TOS = TOS THEN TOS := X << LENGTH = 0, NO DELIM >>                01290000
   ELSE                                                                 01292000
   BEGIN << PUT DELIM ON END >>                                         01294000
      TOS := X; << RESTORE END ADR >>                                   01296000
      BPS0 := DELIM(INDEX); <<ADD DELIM>>                               01298000
      TOS := TOS +1;                                                    01300000
   END;                                                                 01302000
   ASSEMBLE(DUP);                                                       01304000
END UNTIL DELIM(INDEX) = 0;                                             01306000
                                                                        01308000
FORMNAME := TOS -1 -@TARGET;                                            01310000
ASSEMBLE(DEL); <<CLEAN STACK>>                                          01312000
                                                                        01314000
END; << FORMNAME >>                                                     01316000
$TITLE "FORMSG"                                                         01318000
PROCEDURE FORMSG(DIRECTORY,FILENO,SETNO,MSGNO,BUFF,                     01320000
      BUFFSIZE,FILLBUFF,MSGLEN,PARMASK,PARM1,PARM2,PARM3,               01322000
      PARM4,PARM5,DESTFILE,ERRNO);                                      01324000
   VALUE FILENO,SETNO,MSGNO,BUFFSIZE,FILLBUFF,PARMASK,PARM1,            01326000
      PARM2,PARM3,PARM4,PARM5,DESTFILE;                                 01328000
   ARRAY DIRECTORY;                                                     01330000
   INTEGER FILENO,SETNO,MSGNO,BUFFSIZE,MSGLEN,DESTFILE,                 01332000
      ERRNO;                                                            01334000
   BYTE ARRAY BUFF;                                                     01336000
   LOGICAL FILLBUFF,PARMASK,PARM1,PARM2,PARM3,PARM4,PARM5;              01338000
   OPTION INTERNAL;                                                     01340000
COMMENT                                                                 01342000
                                                                        01344000
This procedure assembles and routes messages.  Message is               01346000
fetched from message catalog in a physical block, then moved to         01348000
OUTBUFF as parameters are inserted.  As OUTBUFF is filled it is         01350000
printed.  Also as OUTBUFF fills the message is moved into BUFF          01352000
is FILLBUFF flag is on.                                                 01354000
Note: FORMSG expects the message catalog to be an 80 byte      <<04595>>01356000
standard EDITOR file with valid data in positions 1 through    <<04595>>01358000
72 and line numbers in 73-80.  This is because                 <<04595>>01360000
FORMSG  calls FINDMSG which calls LENBUF to get the            <<04595>>01362000
length of the data in the record.  LENBUF deblanks the record  <<04595>>01364000
from the right beginning in cloumn 72 and stops scanning when  <<04595>>01366000
it reaches the first non-blank character, including the con-   <<04595>>01368000
tinuation characters "&" and "%".                              <<04595>>01370000
                                                                        01372000
DIRECTORY - catalog directory from userlabel in catalog file.           01374000
FILENO    - catalog file number.                                        01376000
SETNO     - same as for GENMESSAGE.                                     01378000
MSGNO     - same as for GENMESSAGE.                                     01380000
BUFF      - output buffer.  Also used as tank for assembled             01382000
            message before it is printed.                               01384000
BUFFSIZE  - size of BUFF in positive bytes.                             01386000
FILLBUFF  - if true then BUFF parameter is present and BUFF             01388000
            will be filled with assembled message.                      01390000
MSGLEN    - size of assembled message in positive bytes.                01392000
PARMASK   - same as for GENMESSAGE.                                     01394000
PARM1 }                                                                 01396000
PARM2 }                                                                 01398000
PARM3 }   - same as for GENMESSAGE.                                     01400000
PARM4 }                                                                 01402000
PARM5 }                                                                 01404000
DESTFILE  - Destination:                                                01406000
            = <-2 - file number.                                        01408000
            = -2  - $STDLIST.                                           01410000
            = -1  - none.                                               01412000
            = >=0 - not used.                                           01414000
ERRNO     - Error number.                                               01416000
                                                                        01418000
RETURNS.                                                                01420000
   CONDITION  CCE = everything OK.                                      01422000
   CODE       CCL = file system error.                                  01424000
              CCG = internal error.  Missing setno or msgno.            01426000
   MSGLEN     - size of assembled message in positive bytes.            01428000
   ERRNO      - error number.                                           01430000
;                                                                       01432000
BEGIN                                                                   01434000
                                                                        01436000
INTEGER                                                                 01438000
   ZEROSTOP,                                                            01440000
   TANKI,                                                               01442000
   INDEX,                                                               01444000
   INLEN,                     <<INPUT BUF: LENGTH  >>                   01446000
   INX,                       <<INPUT BUF: INDEX >>                     01448000
   OUTX,                      <<OUTPUT BUF: INDEX >>                    01450000
  PNUM;                                                        <<02339>>01452000
                                                                        01456000
DOUBLE                                                         <<02339>>01458000
  RECNO;                                                       <<02339>>01460000
                                                               <<02339>>01462000
LOGICAL CRLF,DONE'MSG:=FALSE;                                  <<01214>>01464000
                                                                        01466000
BYTE POINTER BUFFPTR;                                                   01468000
                                                                        01470000
INTEGER ARRAY PARM'IA(*) = PARM1;<<PARM BUF: INPUT >>                   01472000
BYTE ARRAY BUFF1(0:11);       <<PARM BUF: OUTPUT >>                     01474000
ARRAY BLOCKBUFF'(0:RECSIZE*BLKFACTOR);                                  01476000
                                                                        01478000
POINTER OUTBUFF';                                                       01480000
BYTE POINTER OUTBUFF;                                                   01482000
                                                                        01484000
EQUATE                                                         <<04203>>01486000
   AMPERSAND = %320;   << CRLF value for "&" continuation >>   <<04203>>01488000
                                                                        01490000
SUBROUTINE PRINTIT;                                                     01492000
COMMENT                                                                 01494000
   Handles routing of output                                            01496000
;                                                                       01498000
BEGIN                                                                   01500000
                                                                        01502000
IF DESTFILE = -2 THEN                                                   01504000
BEGIN << $STDLIST >>                                                    01506000
   PRINT(OUTBUFF',-OUTX,CRLF);                                          01508000
   IF <> THEN                                                  <<01128>>01510000
      BEGIN                                                    <<01128>>01512000
      ERRNO := WRITEFAIL;                                      <<01128>>01514000
      CCLRETN;                                                 <<01128>>01516000
      END;                                                     <<01128>>01518000
END                                                                     01520000
ELSE                                                                    01522000
IF DESTFILE < -2 THEN                                                   01524000
BEGIN                                                                   01526000
   FWRITE(-DESTFILE,OUTBUFF',-OUTX,CRLF);                               01528000
   IF <> THEN                                                  <<01128>>01530000
      BEGIN                                                    <<01128>>01532000
      ERRNO := WRITEFAIL;                                      <<01128>>01534000
      CCLRETN;                                                 <<01128>>01536000
      END;                                                     <<01128>>01538000
END;                                                                    01540000
                                                                        01542000
IF FILLBUFF THEN                                                        01544000
BEGIN                                                                   01546000
   IF OUTX +MSGLEN > BUFFSIZE THEN                                      01548000
   BEGIN                                                                01550000
      << FILL TO END OF USER'S BUFFER >>                       <<00810>>01552000
      MOVE BUFF(MSGLEN) := OUTBUFF,(BUFFSIZE-MSGLEN);          <<00810>>01554000
      MSGLEN := BUFFSIZE;                                      <<00810>>01556000
      CONDCODE := CCG;                                                  01558000
      ERRNO := BUFFOVERFLOW;                                            01560000
   END                                                                  01562000
   ELSE                                                        <<00810>>01564000
   BEGIN                                                       <<00810>>01566000
      MOVE BUFF(MSGLEN) := OUTBUFF,(OUTX);                     <<00810>>01568000
      MSGLEN := MSGLEN + OUTX;                                 <<00810>>01570000
   END;                                                        <<00810>>01572000
END                                                            <<00810>>01574000
ELSE                                                           <<00810>>01576000
   MSGLEN := MSGLEN + OUTX;                                    <<00810>>01578000
OUTX := 0;  << RESET INDEX TO REFILL OUTBUFF >>                         01580000
                                                                        01582000
END; << SUBROUTINE PRINTIT >>                                           01584000
                                                                        01586000
                                                                        01588000
                                                                        01590000
                                                                        01592000
SUBROUTINE TANK(LENGTH,STRING);                                         01594000
   VALUE LENGTH;                                                        01596000
   INTEGER LENGTH;                                                      01598000
   BYTE ARRAY STRING;                                                   01600000
BEGIN                                                                   01602000
   TANKI := -1;                                                         01604000
   WHILE (TANKI := TANKI+1) < LENGTH DO << TANKING LOOP>>               01606000
   BEGIN                                                                01608000
      IF OUTX >= BUFFSIZE THEN PRINTIT; << PRINT AND FLUSH >>  <<01214>>01610000
      OUTBUFF(OUTX) := STRING(TANKI);   << TANK STRING >>      <<01214>>01612000
      OUTX := OUTX + 1;                 << ADVANCE INDEX >>    <<01214>>01614000
   END; <<TANK LOOP>>                                                   01616000
END; << TANK >>                                                         01618000
                                                                        01620000
SUBROUTINE INSERTPARM;                                                  01622000
BEGIN                                                                   01624000
   << CATCH BOUNDARY CONDITION ON LAST CHAR "!" >>             <<00261>>01626000
   IF PNUM >= 5 THEN RETURN;                                   <<00261>>01628000
   CASE *INTEGER((PARMASK &CSL(4+PNUM*3)) LAND 3) OF                    01630000
   BEGIN  << PARM N >>                                                  01632000
      BEGIN << 0: STRING PARM >>                                        01634000
         TOS := PARM'IA(PNUM);                                          01636000
         ASSEMBLE(DUP,DUP);                                             01638000
         SCAN * UNTIL 0,1;                                              01640000
         ASSEMBLE(XCH,SUB;XCH);                                         01642000
         TANK(*,*);                                                     01644000
      END;                                                              01646000
                                                                        01648000
      << 1: INTEGER BY VALUE >>                                         01650000
      TANK(ASCII(PARM'IA(PNUM),10,BUFF1),BUFF1);                        01652000
                                                                        01654000
      << 2: DOUBLE BY REFERENCE >>                                      01656000
      BEGIN                                                             01658000
         TOS := PARM'IA(PNUM);                                          01660000
         TANK(DASCII(DPS0,10,BUFF1),BUFF1); DEL;                        01662000
      END;                                                              01664000
                                                                        01666000
      ;<< 3 IGNORE PARM >>                                              01668000
                                                                        01670000
   END; << CASE OF PARMS >>                                             01672000
   PNUM := PNUM+1;                                                      01674000
END; <<INSERTPARM>>                                                     01676000
                                                                        01678000
   << MAIN BODY >>                                                      01680000
                                                                        01682000
                                                                        01684000
   << SET UP VARIABLES >>                                               01686000
MSGLEN := CRLF := ZEROSTOP := 0;<<STOPPER FOR INPUT STRING>>            01688000
CONDCODE := CCE;                                                        01690000
                                                                        01692000
   << ALLOCATE OUTPUT BUFFER >>                                         01694000
COMMENT.                                                       <<04595>>01696000
Allocate an S relative array by creating an array on the       <<04595>>01698000
stack.  Looks like:                                            <<04595>>01700000
                  -----------------                            <<04595>>01702000
     OUTBUF ==>   |               | <== Previous S             <<04595>>01704000
                  |               |                            <<04595>>01706000
                  |               |                            <<04595>>01708000
                  \               \                            <<04595>>01710000
                  ~               ~                            <<04595>>01712000
                  \               \                            <<04595>>01714000
                  |               |                            <<04595>>01716000
                  |               | <== S when add S is done   <<04595>>01718000
                  -----------------                            <<04595>>01720000
;                                                              <<04595>>01722000
ASSEMBLE( ZERO; LRA S-0);                                               01724000
@OUTBUFF' := TOS;                                                       01726000
@OUTBUFF := @OUTBUFF'&LSL(1);                                           01728000
TOS := (BUFFSIZE +1)&LSR(1);                                            01730000
ASSEMBLE( ADDS 0 );                                                     01732000
                                                                        01734000
RECNO := FINDMSG(DIRECTORY,FILENO,SETNO,MSGNO,BLOCKBUFF',               01736000
            BUFFPTR,INLEN,CRLF,ERRNO);                                  01738000
IF > THEN CCGRETN;                                                      01740000
IF < THEN CCLRETN;                                                      01742000
                                                                        01744000
<< SET UP LOOP VARIABLES >>                                             01746000
PNUM := INDEX := INX := OUTX := 0;                                      01748000
                                                                        01750000
<< NOW GO TO WORK ON INPUT STRING & FORMAT >>                           01752000
                                                                        01754000
LOOP:                                                                   01756000
WHILE NOT DONE'MSG DO                                          <<01214>>01758000
BEGIN                                                          <<01214>>01760000
   << REFILL BUFF? >>                                                   01762000
   IF INDEX >= INLEN THEN <<END OF LINE>>                               01764000
   BEGIN                                                                01766000
      TANK(INDEX-INX,BUFFPTR(INX));<<EMPTY BUFF>>                       01768000
      PRINTIT;    << FLUSH OUTBUFF >>                          <<01214>>01770000
      INX := INDEX:= 0;                                                 01772000
      IF RECNO <> 0D THEN                                      <<02339>>01774000
      BEGIN                                                             01776000
                                                               <<04203>>01778000
      << When the message is returned to a user buffer, we  >> <<04203>>01780000
      << must ensure there is a blank between the concate-  >> <<04203>>01782000
      << nated lines of a multi-line message.  If the       >> <<04203>>01784000
      << continuation character is an "&", the blank should >> <<04203>>01786000
      << not be inserted since the user has requested that  >> <<04203>>01788000
      << pure concatenation be performed.                   >> <<04203>>01790000
                                                               <<04203>>01792000
         IF FILLBUFF AND CRLF <> AMPERSAND THEN                <<04203>>01794000
            BEGIN                                              <<04203>>01796000
                                                               <<04203>>01798000
         << Make sure there is room for the blank. >>          <<04203>>01800000
            IF MSGLEN + 1 <= BUFFSIZE THEN                     <<04203>>01802000
               BEGIN                                           <<04203>>01804000
               BUFF(MSGLEN) := " ";                            <<04203>>01806000
               MSGLEN := MSGLEN + 1;                           <<04203>>01808000
               END;                                            <<04203>>01810000
                                                               <<04203>>01812000
            END;                                               <<04203>>01814000
                                                               <<04203>>01816000
         READCAT(FILENO,RECNO,DIRECTORY(CURRENTRECELL),                 01818000
            BLOCKBUFF',BUFFPTR);                                        01820000
         IF < THEN                                             <<01128>>01822000
            BEGIN                                              <<01128>>01824000
            ERRNO := READFAIL;                                 <<01128>>01826000
            CCLRETN;                                           <<01128>>01828000
            END;                                               <<01128>>01830000
         << NOW GET LENGTH,CRLF, CONT'D >>                     <<01128>>01832000
         LENBUF(BUFFPTR,INLEN,CRLF,RECNO);                     <<01128>>01834000
         INDEX := -1; << RESET FOR LOOP>>                               01836000
      END                                                               01838000
      ELSE                                                              01840000
      DONE'MSG := TRUE;                                        <<01214>>01842000
   END                                                         <<01214>>01844000
   ELSE       << INSERT PARM? >>                               <<01214>>01846000
   IF BUFFPTR(INDEX) = "!" THEN                                <<01214>>01848000
   BEGIN                                                       <<01214>>01850000
      TANK(INDEX-INX,BUFFPTR(INX));<<DUMP BUFF UP TO !>>       <<01214>>01852000
      IF NOT PARMASK&CSL(1) THEN                               <<01214>>01854000
      BEGIN << PARMS PRESENT >>                                <<01214>>01856000
         INSERTPARM;                                           <<01214>>01858000
         INX := INDEX+1; << ADVANCE PAST ! >>                  <<01214>>01860000
      END                                                      <<01214>>01862000
      ELSE INX := INDEX; <<! WASN'T PARM >>                    <<01214>>01864000
   END;                                                        <<01214>>01866000
                                                               <<01214>>01868000
   INDEX := INDEX+1;                                                    01870000
END;  << END PROCESSING MESSAGE >>                             <<01214>>01872000
                                                                        01874000
OUTL:                                                                   01876000
                                                                        01878000
END; << FORMSG >>                                                       01880000
$TITLE "GENMESSAGE  - MESSAGE SYSTEM INTRINSIC"                         01882000
INTEGER PROCEDURE GENMESSAGE(FILENO,SETNO,MSGNO,BUFF,BUFFSIZE,          01884000
      PARMASK,PARM1,PARM2,PARM3,PARM4,PARM5,DESTFILE,ERRNO);            01886000
   VALUE FILENO,SETNO,MSGNO,BUFFSIZE,PARMASK,PARM1,PARM2,               01888000
      PARM3,PARM4,PARM5,DESTFILE;                                       01890000
   INTEGER FILENO,SETNO,MSGNO,BUFFSIZE,DESTFILE,ERRNO;                  01892000
   BYTE ARRAY BUFF;                                                     01894000
   LOGICAL PARMASK,PARM1,PARM2,PARM3,PARM4,PARM5;                       01896000
   OPTION VARIABLE;                                                     01898000
                                                                        01900000
COMMENT                                                                 01902000
   Callable message system interface.  GENMESSAGE is called             01904000
with a message number.   A message is fetched from the                  01906000
catalog, parameters are inserted, and the assembled                     01908000
message is returned in a buffer.                                        01910000
Note: GENMESSAGE expects the message catalog to be an 80 byte  <<04595>>01912000
standard EDITOR file with valid data in positions 1 through    <<04595>>01914000
72 and line numbers in 73-80.  This is because GENMESSAGE      <<04595>>01916000
calls FORMSG which calls FINDMSG which calls LENBUF to get the <<04595>>01918000
length of the data in the record.  LENBUF deblanks the record  <<04595>>01920000
from the right beginning in column 72 and stops scanning when  <<04595>>01922000
it reaches the first non-blank character, including the con-   <<04595>>01924000
tinuation characters "&" and "%".                              <<04595>>01926000
                                                                        01928000
PARAMETERS.                                                             01930000
   FILENO   - Indicates file for message catalog.  Required             01932000
              parameter.                                                01934000
   SETNO    - Message set number within catalog.  Must be a             01936000
              positive integer.  Required parameter.                    01938000
   MSGNO    - Message number within the message set.  Must be a         01940000
              positive integer or zero.  Required parameter.            01942000
   BUFF     - If present, assembled message is placed in this           01944000
              array.  Message is terminated by ASCII null (0).          01946000
   BUFFSIZE - Passed in to indicate size of BUFF in positive            01948000
              bytes.  If parameter is missing, 72 bytes in used         01950000
              as BUFF size.                                             01952000
   PARMASK  - Indicates parameter type for PARM1, PARM2, PARM3,         01954000
              PARM4, and PARM5.  If parameter is missing then           01956000
              GENMESSAGE ignores parameters.  PARMASK has the           01958000
              following bit definitions:                                01960000
              .(0:1)=1-use rest of word as alternate parameter          01962000
                       control:                                         01964000
                       .(1:15) = 0 - ignore parameters.                 01966000
                    =0-use following partial word designators           01968000
                       for parameters:                                  01970000
                       .(1:3)  = PARM1 TYPE (see below).                01972000
                       .(4:3)  = PARM2 TYPE (see below).                01974000
                       .(7:3)  = PARM3 TYPE (see below).                01976000
                       .(10:3) = PARM4 TYPE (see below).                01978000
                       .(13:3) = PARM5 TYPE (see below).                01980000
                       TYPE- 0 = Parm is a string, terminated           01982000
                                 by an ASCII null (0).  (This           01984000
                                 is passed by @arrayname.)              01986000
                             1 = Parm is integer.                       01988000
                             2 = Parm is double by reference.           01990000
                                 (This is passed by                     01992000
                                 @doublename.)                          01994000
                             3 = Ignore this parm.                      01996000
   PARM1}                                                               01998000
   PARM2}                                                               02000000
   PARM3}   - Parameter(s) to be inserted into message.                 02002000
   PARM4}                                                               02004000
   PARM5}                                                               02006000
   DESTFILE - Destination of assembled message:                         02008000
              missing = If BUFF is missing, send to $STDLIST.           02010000
                        If BUFF is present, nowhere.                    02012000
                  = 0 - $STDLIST.                                       02014000
                  > 2 - file number of destination file.                02016000
   ERRNO    - Indicates error number.  Error not returned if            02018000
              parameter is absent.  ERRNO = 0 - everything OK.          02020000
              ERRNO > 0 - internal error number.                        02022000
RETURNS.                                                                02024000
   CONDITION  CCE = everything OK.                                      02026000
   CODE       CCL = file system error.                                  02028000
              CCG = something wrong with call. May have missing         02030000
                    required parameter, invalid file number or          02032000
                    invalid parameter.                                  02034000
   GENMESSAGE-positive byte count of assembled message.                 02036000
   BUFF     - Assembled message terminated by an ASCII null             02038000
              (0).                                                      02040000
   ERRNO    - ERRNO = 0 - everything OK.  ERRNO > 0 - internal          02042000
              error number.                                             02044000
;                                                                       02046000
BEGIN                                                                   02048000
                                                                        02050000
   << INSERT LOCALS HERE >>                                             02052000
                                                                        02054000
DEFINE                                                                  02056000
   PFILENO    = ( 3:1) #,                                               02058000
   PSETNO     = ( 4:1) #,                                               02060000
   PMSGNO     = ( 5:1) #,                                               02062000
   PBUFF      = ( 6:1) #,                                               02064000
   PBUFFSIZE  = ( 7:1) #,                                               02066000
   PPARMASK   = ( 8:1) #,                                               02068000
   PDESTFILE  = (14:1) #,                                               02070000
   PERRNO     = (15:1) #;                                               02072000
                                                                        02074000
EQUATE                                                                  02076000
   PARM5OFFSET= 2; <<PARM5 IS 2ND TO LAST PARM>>                        02078000
                                                                        02080000
                                                                        02082000
LOGICAL PMASK = Q-4;                                                    02084000
LOGICAL                                                        <<04595>>02086000
   FILLBUFF;     <<USED TO SEND TO FORMSG >>                   <<04595>>02088000
                                                               <<04595>>02090000
                                                                        02092000
INTEGER                                                                 02094000
   MSGLEN = GENMESSAGE,                                                 02096000
   BUFFERSIZE,   <<USED TO SEND TO FORMSG >>                   <<04595>>02098000
   ERRNOLOCAL;                                                          02100000
ARRAY DIRECTORY(0:MSGDIRSIZE);                                          02102000
                                                               <<01526>>02104000
LOGICAL  AOPTS;                                                <<01526>>02106000
INTRINSIC  FGETINFO;                                           <<01526>>02108000
                                                                        02110000
                                                                        02112000
                                                                        02114000
   << SUBROUTINES >>                                                    02116000
<<*********************************************************>>  <<04595>>02118000
<<                                                         >>  <<04595>>02120000
<<                  G O O D B U F F S I Z E                >>  <<04595>>02122000
<<                                                         >>  <<04595>>02124000
<<*********************************************************>>  <<04595>>02126000
                                                                        02128000
LOGICAL SUBROUTINE GOODBUFFSIZE;                                        02130000
BEGIN                                                                   02132000
   IF PMASK.PBUFFSIZE THEN                                              02134000
   BEGIN                                                                02136000
      IF BUFFSIZE >0 THEN GOODBUFFSIZE := TRUE;                         02138000
   END                                                                  02140000
   ELSE GOODBUFFSIZE := TRUE;                                           02142000
END; << SUBROUTINE GOODBUFFSIZE >>                                      02144000
                                                                        02146000
                                                                        02148000
<<*********************************************************>>  <<04595>>02150000
<<                                                         >>  <<04595>>02152000
<<                 G O O D D E S T F I L E                 >>  <<04595>>02154000
<<                                                         >>  <<04595>>02156000
<<*********************************************************>>  <<04595>>02158000
LOGICAL SUBROUTINE GOODDESTFILE;                                        02160000
BEGIN                                                                   02162000
                                                                        02164000
IF PMASK.PDESTFILE THEN                                                 02166000
BEGIN       << user specified a destination file      >>       <<04595>>02168000
   IF DESTFILE >= 0 THEN                                                02170000
   BEGIN                                                                02172000
      DESTFILE := IF DESTFILE = 0 THEN -2 <<$STDLIST>>                  02174000
         ELSE -DESTFILE; << FILE NO. >>                                 02176000
      GOODDESTFILE := TRUE;                                             02178000
   END;                                                                 02180000
END                                                                     02182000
ELSE                                                                    02184000
BEGIN       << user did not specify destination file  >>       <<04595>>02186000
            << set flag for FORMSG call.  -1 for user >>       <<04595>>02188000
            << specified buffer or -2 for $STDLIST.   >>       <<04595>>02190000
   DESTFILE := IF PMASK.PBUFF THEN -1 <<NOWHERE>>                       02192000
      ELSE -2; <<$STDLIST>>                                             02194000
   GOODDESTFILE := TRUE;                                                02196000
END;                                                                    02198000
                                                                        02200000
END; << SUBROUTINE GOODDESTFILE >>                                      02202000
                                                               <<01526>>02204000
LOGICAL SUBROUTINE GOODFILE;                                   <<01526>>02206000
BEGIN                                                          <<01526>>02208000
                                                               <<01526>>02210000
<< CHECKS FILENO TO MAKE SURE IT WAS OPENED CORRECTLY. >>      <<01526>>02212000
   FGETINFO( FILENO, , , AOPTS );                              <<01526>>02214000
   IF <> THEN GOODFILE := FALSE                                <<01526>>02216000
   ELSE                                                        <<01526>>02218000
   BEGIN                                                       <<01526>>02220000
                                                               <<01526>>02222000
      IF   AOPTS.(11:1) <> 1   << NOT MULTI-RECORD >>          <<01526>>02224000
         THEN GOODFILE := FALSE                                <<01526>>02226000
         ELSE GOODFILE := TRUE;                                <<01526>>02228000
                                                               <<01526>>02230000
   END;                                                        <<01526>>02232000
                                                               <<01526>>02234000
END;  << GOODFILE >>                                           <<01526>>02236000
                                                               <<01526>>02238000
LOGICAL SUBROUTINE CHECKPARMS(ERRNOLOCAL);                              02240000
   INTEGER ERRNOLOCAL;                                                  02242000
BEGIN                                                                   02244000
                                                                        02246000
CONDCODE := CCG; << SET BAD >>                                          02248000
IF NOT PMASK.PFILENO THEN ERRNOLOCAL := NOFILENOPARM                    02250000
ELSE IF NOT PMASK.PSETNO THEN ERRNOLOCAL := NOSETNOPARM                 02252000
ELSE IF NOT PMASK.PMSGNO THEN ERRNOLOCAL := NOMSGNOPARM                 02254000
                                                                        02256000
   << REQUIRED PARMS PRESENT >>                                         02258000
ELSE IF SETNO <= 0 THEN ERRNOLOCAL := INVSETNO                          02260000
ELSE IF SETNO > MAXNOSETS THEN ERRNOLOCAL := SETNOTOOBIG                02262000
ELSE IF MSGNO < 0 THEN ERRNOLOCAL := INVMSGNO                           02264000
ELSE IF NOT GOODBUFFSIZE THEN ERRNOLOCAL := INVBUFFSIZE                 02266000
ELSE IF NOT GOODDESTFILE THEN ERRNOLOCAL := INVDESTFILE                 02268000
ELSE                                                                    02270000
BEGIN                                                                   02272000
   CONDCODE := CCE;                                                     02274000
   ERRNOLOCAL := 0;                                                     02276000
   CHECKPARMS := TRUE;                                                  02278000
END;                                                                    02280000
                                                                        02282000
END; << SUBROUTINE CHECKPARMS >>                                        02284000
                                                                        02286000
                                                                        02288000
SUBROUTINE MASKPARMS;                                                   02290000
BEGIN << SETS UP FOR ALL FIVE PARMS >>                                  02292000
                                                                        02294000
IF PMASK.PPARMASK AND NOT PARMASK&CSL(1) THEN                           02296000
BEGIN << PARMASK PRESENT & NOT SET TO IGNORE ALL PARMS>>                02298000
   TOS := PMASK&LSR(PARM5OFFSET);<<RIGHT JUSTIFY P1-P5 MASK>>           02300000
   X := 15; <<P5 IS BIT 15>>                                            02302000
   DO BEGIN                                                             02304000
      ASSEMBLE(TBC 0,X);                                                02306000
      IF = THEN PARMASK.(13:3) := 3; <<IGNORE PARM>>                    02308000
      PARMASK := PARMASK&CSR(3);                                        02310000
   END UNTIL (X := X-1) = 10;                                           02312000
   DEL; << POP PMASK >>                                                 02314000
   PARMASK := PARMASK &CSR(1);                                          02316000
END                                                                     02318000
ELSE PARMASK := -1;<<IGNORE ALL PARMS>>                                 02320000
                                                                        02322000
END; << SUBROUTINE MASKPARMS >>                                         02324000
                                                                        02326000
                                                                        02328000
   << MAIN PROCEDURE BODY >>                                            02330000
                                                                        02332000
IF CHECKPARMS(ERRNOLOCAL) THEN                                          02334000
BEGIN                                                                   02336000
      << GOODDESTFILE IN CHECKPARMS SETS UP DESTFILE >>                 02338000
                                                                        02340000
   MASKPARMS; << SETS UP PARMASK FOR FORMSG >>                          02342000
                                                               <<01526>>02344000
<< CHECK FILE OPTIONS.                                  >>     <<01526>>02346000
IF NOT GOODFILE THEN                                           <<01526>>02348000
BEGIN                                                          <<01526>>02350000
                                                               <<01526>>02352000
   CONDCODE := CCG;                                            <<01526>>02354000
   ERRNOLOCAL := BADFILEOPTIONS;                               <<01526>>02356000
                                                               <<01526>>02358000
END                                                            <<01526>>02360000
ELSE                                                           <<01526>>02362000
BEGIN                                                          <<01526>>02364000
         << GET DIRECTORY >>                                            02366000
   FREADLABEL(FILENO,DIRECTORY,MSGDIRSIZE);                             02368000
   IF = THEN                                                            02370000
   BEGIN                                                       <<04595>>02372000
      IF PMASK.PBUFFSIZE THEN                                  <<04595>>02374000
         BUFFERSIZE := BUFFSIZE                                <<04595>>02376000
      ELSE                                                     <<04595>>02378000
         BUFFERSIZE := DATASIZEB;   <<DATASIZEB = 72 >>        <<04595>>02380000
      IF PMASK.PBUFF THEN                                      <<04595>>02382000
         FILLBUFF := TRUE                                      <<04595>>02384000
      ELSE                                                     <<04595>>02386000
         FILLBUFF := FALSE;                                    <<04595>>02388000
                                                               <<04595>>02390000
      FORMSG(DIRECTORY,FILENO,SETNO,MSGNO,BUFF,                <<04595>>02392000
             BUFFERSIZE,FILLBUFF,MSGLEN,PARMASK,               <<04595>>02394000
             PARM1,PARM2,PARM3,PARM4,PARM5,                    <<04595>>02396000
             DESTFILE,ERRNOLOCAL);                             <<04595>>02398000
                                                               <<04595>>02400000
      IF <> THEN                                               <<01128>>02402000
        IF < THEN                                              <<01128>>02404000
          CONDCODE := CCL                                      <<01128>>02406000
        ELSE IF > THEN                                         <<01128>>02408000
          CONDCODE := CCG                                      <<01128>>02410000
   END                                                                  02412000
   ELSE                                                                 02414000
   BEGIN                                                                02416000
      CONDCODE := CCL;                                                  02418000
      ERRNOLOCAL := READLABELFAIL;                                      02420000
   END;                                                                 02422000
END;                                                                    02424000
                                                                        02426000
END;                                                           <<01526>>02428000
   << CONDCODE & ERRNOLOCAL SET BY CHECKPARMS >>                        02430000
                                                                        02432000
IF PMASK.PERRNO THEN ERRNO := ERRNOLOCAL;                               02434000
                                                                        02436000
END; << GENMESSAGE >>                                                   02438000
$TITLE "GETNUM"                                                         02440000
INTEGER PROCEDURE GETNUM(PTR,NUM);                                      02442000
   VALUE PTR;                                                           02444000
   BYTE POINTER PTR;                                                    02446000
   INTEGER NUM;                                                         02448000
COMMENT                                                                 02450000
   USED BY CONVERTDATE & CONVERTTIME TO DEBLANK PTR &                   02452000
   CONVERT STRING TO BINARY. RETURNS POINTER TO NEXT NON-               02454000
   NUMERIC CHAR. CONDITION CODE CCE IF OK, CCG IF NOT.                  02456000
;                                                                       02458000
BEGIN                                                                   02460000
                                                                        02462000
EQUATE                                                                  02464000
   CCG = 0,                                                             02466000
   CCE = 2;                                                             02468000
                                                                        02470000
INTEGER                                                                 02472000
   STATUS = Q-1,                                                        02474000
   LEN;                                                                 02476000
                                                                        02478000
STATUS.(6:2) := CCE;                                                    02480000
SCAN PTR WHILE " ",1;<<STRIP BLANKS>>                                   02482000
@PTR := TOS;                                                            02484000
MOVE PTR := PTR WHILE N,1;                                              02486000
LEN := TOS -@PTR;                                                       02488000
NUM := BINARY(PTR,LEN);                                                 02490000
IF <>  OR LEN = 0 THEN STATUS.(6:2) := CCG;                             02492000
SCAN PTR(LEN) WHILE " ",1;<<STRIP TRAILING BLANKS>>                     02494000
GETNUM := TOS;                                                          02496000
                                                                        02498000
END; << GETNUM >>                                                       02500000
$TITLE "LENBUF - FINDS LENGTH, CRLF & CONTINUED"                        02502000
PROCEDURE LENBUF(BUFF,LEN,CRLF,RECNO);                                  02504000
   BYTE ARRAY BUFF;                                                     02506000
   INTEGER LEN;                                                <<02339>>02508000
   DOUBLE RECNO;                                               <<02339>>02510000
   LOGICAL CRLF;                                                        02512000
   OPTION INTERNAL;                                                     02514000
BEGIN                                                                   02516000
                                                                        02518000
                                                                        02520000
INTEGER SUBROUTINE DEBLANK(BUFF,WIDTH);                                 02522000
   VALUE WIDTH; INTEGER WIDTH;                                          02524000
   BYTE ARRAY BUFF;                                                     02526000
COMMENT                                                                 02528000
   DEBLANKS ON RIGHT                                                    02530000
;                                                                       02532000
BEGIN                                                                   02534000
                                                                        02536000
X := WIDTH -1;                                                          02538000
IF BUFF(X) <> " " THEN DEBLANK := WIDTH                                 02540000
ELSE                                                                    02542000
BEGIN                                                                   02544000
   TOS := @BUFF(X);                                                     02546000
   ASSEMBLE(DUP,DECA);                                                  02548000
   TOS := -X;                                                           02550000
   ASSEMBLE(CMPB 0);                                                    02552000
   S6 := -TOS;  << DEBLANK := -TOS >>                                   02554000
   DDEL;                                                                02556000
END;                                                                    02558000
                                                                        02560000
END; << DEBLANK >>                                                      02562000
                                                                        02564000
   << FIND LENGTH OF MSG & IF CONTINUED ON NEXT REC >>                  02566000
CRLF := 0;                                                              02568000
LEN := DEBLANK(BUFF,DATASIZEB);                                         02570000
IF LEN=0 THEN     << COMPLETELY BLANK LINE >>                  <<01213>>02572000
BEGIN                                                          <<01213>>02574000
   RECNO := 0D;                                                <<02339>>02576000
   RETURN;                                                     <<01213>>02578000
END;                                                           <<01213>>02580000
IF BUFF(X:=LEN-1) = "&" OR BUFF(X) = "%" THEN                           02582000
BEGIN                                                                   02584000
   IF BUFF(X) = "&" THEN CRLF := %320;                                  02586000
   RECNO := RECNO + 1D;   << CONTINUED ON NEXT RECORD >>       <<02339>>02588000
      << NOW FIND LENGTH WITHOUT % OR & >>                              02590000
   LEN := IF LEN=1 THEN 0                                      <<01213>>02592000
                   ELSE DEBLANK(BUFF,LEN-1);                   <<01213>>02594000
END                                                                     02596000
ELSE  RECNO := 0D;        << NOT CONTINUED >>                  <<02339>>02598000
                                                                        02600000
END; <<  LENBUF >>                                                      02602000
$TITLE "NEXTPARM, FINDPARM"                                             02604000
INTEGER PROCEDURE NEXTPARMD(DELIMS,STRING,PARMPTR,DELIMPTR);            02606000
   BYTE ARRAY DELIMS,STRING;                                            02608000
   BYTE POINTER PARMPTR,DELIMPTR;                                       02610000
   OPTION VARIABLE;                                                     02612000
COMMENT                                                                 02614000
                                                                        02616000
NEXTPARM:                                                               02618000
   STARTS WITH STRING POINTING AT DELIM OR BLANK. RETURNS               02620000
   PARMPTR POINTING TO PARM & 'NEXTPARM' IS LENGTH. DELIMPTR            02622000
   POINTS TO TRAILING DELIMITER. ALL "STRING" IS UPSHIFTED              02624000
                                                                        02626000
   BOTH PARMPTR & DELIMPTR ARE OPTIONAL.                                02628000
                                                                        02630000
   CARRY     = SET IF 0 IS HIT (STRING MUST BE TERM. BY 0).             02632000
   CONDCODE  =    CCG   OK, LENGTH IS RETURNED.                         02634000
                  CCL   NO TRAILING QUOTE.                              02636000
                  CCE   LENGTH IS ZERO.                                 02638000
                                                                        02640000
   DELIMITERS ARE:  BLANK, "," , SEMICOLON , "="                        02642000
                                                                        02644000
FINDPARM:                                                               02646000
   SAME AS NEXTPARM EXCEPT NO LEADING DELIMITER IS SKIPPED.             02648000
                                                                        02650000
   '  ["]PARAMETER["]  ,'                                               02652000
    ^    ^             ^                                                02654000
    \    \             \--RETURNED DELIMPTR                             02656000
     \    \---------------RETURNED PARMPTR                              02658000
      \-------------------STRING AT ENTRY                               02660000
;                                                                       02662000
BEGIN                                                                   02664000
                                                                        02666000
ENTRY FINDPARMD;                                                        02668000
                                                                        02670000
LOGICAL                                                                 02672000
   STOPPER,                                                             02674000
   INDEX, << USED BY SAWDELIM >>                                        02676000
   PMASK = Q-4,                                                         02678000
   STATUS = Q-1;                                                        02680000
BYTE POINTER                                                            02682000
   PTR,                                                                 02684000
   NPTR;                                                                02686000
                                                                        02688000
LOGICAL NEXTPARMENTRY := FALSE;                                         02690000
                                                                        02692000
LOGICAL SUBROUTINE SAWDELIM(PNTR);                                      02694000
   VALUE PNTR; BYTE POINTER PNTR;                                       02696000
BEGIN                                                                   02698000
   INDEX := 0;                                                          02700000
   WHILE (LOGICAL(DELIMS(INDEX) <> PNTR) LAND                           02702000
      LOGICAL(DELIMS(INDEX) <> 0)) DO                                   02704000
      INDEX := INDEX +1;                                                02706000
   IF DELIMS(INDEX) = PNTR THEN SAWDELIM := TRUE;                       02708000
END; << SUBROUTINE SAWDELIM >>                                          02710000
                                                                        02712000
                                                                        02714000
NEXTPARMENTRY := TRUE;                                                  02716000
                                                                        02718000
FINDPARMD:                                                              02720000
                                                                        02722000
STATUS.(5:3) := 6; << CARRY, CCE; FAILURE >>                            02724000
@PTR := @NPTR := @STRING;                                               02726000
STOPPER := 0; << 0 FOR RUNAWAY STOP >>                                  02728000
                                                                        02730000
IF NOT PMASK.(13:1) THEN GO OUTL; << NEED STRING >>                     02732000
                                                                        02734000
                                                                        02736000
SCAN PTR WHILE " ",1; << DEBLANK >>                                     02738000
@PTR := TOS;                                                            02740000
IF CARRY THEN                                                           02742000
BEGIN                                                                   02744000
   @NPTR := @PTR; << POINT DELIMPTR AT STOPPER (0) >>                   02746000
   GO OUTL;                                                             02748000
END;                                                                    02750000
IF NEXTPARMENTRY THEN << NEXTPARM ENTRY POINT >>                        02752000
BEGIN                                                                   02754000
                                                                        02756000
      << DEBLANK AFTER DELIM IF DELIM NOT BLANK >>                      02758000
   IF SAWDELIM(PTR) THEN                                                02760000
   BEGIN                                                                02762000
      SCAN PTR(1) WHILE " ",1; << DEBLANK AFTER DELIM >>                02764000
      @PTR := TOS;                                                      02766000
      IF CARRY THEN                                                     02768000
      BEGIN                                                             02770000
         @NPTR := @PTR; << POINT DELIMPTR AT STOPPER (0) >>             02772000
         GO OUTL;                                                       02774000
      END;                                                              02776000
   END;                                                                 02778000
END;                                                                    02780000
                                                                        02782000
   <<SOMETHING BESIDES BLANKS>>                                         02784000
IF PTR = """" THEN                                                      02786000
BEGIN                                                                   02788000
   @PTR := @PTR(1);                                                     02790000
   SCAN PTR UNTIL """",1;                                               02792000
   @NPTR := TOS;                                                        02794000
   IF CARRY THEN                                                        02796000
   BEGIN                                                                02798000
   STATUS.(6:2) := 1; <<CCL: NO CLOSE QUOTE >>                          02800000
   GO OUTL;                                                             02802000
   END;                                                                 02804000
   NEXTPARMD := @NPTR -@PTR;                                            02806000
   IF > THEN STATUS.(6:2) := CCG;                                       02808000
   @NPTR := @NPTR(1); << SKIP ">>                                       02810000
      << NPTR AFTER END OF PARM & AFTER " >>                            02812000
      << LENGTH IS SET                    >>                            02814000
END                                                                     02816000
ELSE                                                                    02818000
BEGIN                                                                   02820000
   @NPTR := @PTR(-1);                                                   02822000
   DO @NPTR := @NPTR(1) UNTIL                                           02824000
      NPTR = " " OR SAWDELIM(NPTR);                                     02826000
   NEXTPARMD := @NPTR -@PTR;                                            02828000
   IF > THEN CONDCODE := CCG;                                           02830000
      << NPTR AT DELIM. LENGTH IS SET >>                                02832000
END;                                                                    02834000
   << NOW LOOK FOR 1ST NON-BLANK >>                                     02836000
SCAN NPTR WHILE " ",1;                                                  02838000
@NPTR := TOS;                                                           02840000
IF NOCARRY THEN                                                         02842000
BEGIN                                                                   02844000
   STATUS.(5:1) := 0; << CARRY >>                                       02846000
                                                                        02848000
      << SOLVE PROBLEM OF BLANK AS DELIM >>                             02850000
   IF NOT SAWDELIM(NPTR) THEN @NPTR := @NPTR(-1);                       02852000
      << IF POINTING AT NEXT PARM, BACK UP >>                           02854000
END;                                                                    02856000
                                                                        02858000
OUTL:                                                                   02860000
                                                                        02862000
IF PMASK.(14:1) THEN @PARMPTR := @PTR;                                  02864000
IF PMASK.(15:1) THEN @DELIMPTR := @NPTR;                                02866000
END; << FINDPARM,NEXTPARM >>                                            02868000
INTEGER PROCEDURE NEXTPARM(STRING,PARMPTR,DELIMPTR);                    02870000
   BYTE ARRAY STRING;                                                   02872000
   BYTE POINTER PARMPTR,DELIMPTR;                                       02874000
   OPTION VARIABLE;                                                     02876000
BEGIN                                                                   02878000
                                                                        02880000
LOGICAL                                                                 02882000
   STATUS = Q-1,                                                        02884000
   PARMASK = Q-4,                                                       02886000
   NEXTPARMENTRY := FALSE;                                              02888000
                                                                        02890000
BYTE ARRAY DELIMS(0:3);                                                 02892000
                                                                        02894000
ENTRY FINDPARM;                                                         02896000
                                                                        02898000
NEXTPARMENTRY := TRUE;                                                  02900000
                                                                        02902000
FINDPARM:                                                               02904000
                                                                        02906000
MOVE DELIMS := (",;=",0);                                               02908000
TOS :=0;                                                                02910000
TOS := @DELIMS;                                                         02912000
TOS := @STRING;                                                         02914000
ASSEMBLE(LOAD PARMPTR);                                                 02916000
ASSEMBLE(LOAD DELIMPTR);                                                02918000
TOS := PARMASK;                                                         02920000
IF NEXTPARMENTRY THEN ASSEMBLE(PCAL NEXTPARMD) ELSE                     02922000
   ASSEMBLE(PCAL FINDPARMD);                                            02924000
NEXTPARM := TOS;                                                        02926000
PUSH(STATUS);                                                           02928000
TOS := TOS.(5:3);                                                       02930000
STATUS.(5:3) := TOS; << SET CARRY, CC >>                                02932000
                                                                        02934000
END; << PROCEDURE NEXTPARM, FINDPARM >>                                 02936000
$TITLE "QUALIFYFILENAME"                                                02938000
PROCEDURE QUALIFYFILENAME(OLDFNAME,NEWFNAME);                           02940000
   BYTE ARRAY OLDFNAME, <<INPUT FILE NAME>>                             02942000
              NEWFNAME; <<OUTPUT (FULLY QUALIFIED) FILE NAME>>          02944000
COMMENT                                                                 02946000
   THIS PROCEDURE TAKES OLDFNAME AND CONVERTS IT INTO A                 02948000
   FULLY QUALIFIED FILE NAME WITH THE ADDITION OF HOME GROUP            02950000
   AND ACCOUNT AS REQUIRED.  THE NAME IS RETURNED IN NEWFNAME           02952000
   WITH A 0 (ASCII NULL) AS THE TRAILING DELIMITER.  IT ASSUMES         02954000
   OLDFNAME IS A VALID (POSSIBLY FULLY QUALIFIED) FILE NAME.            02956000
   IT ALSO ASSUMES THAT NEWFNAME CAN HOLD THE MAXIMUM FILE              02958000
   NAME (36 CHARACTERS IF LOCKWORD INCLUDED, 27 IF NO LOCKWORD          02960000
;                                                                       02962000
BEGIN                                                                   02964000
BYTE ARRAY HOMEGROUP(0:8);                                              02966000
BYTE ARRAY HOMEACCT(0:8);                                               02968000
IF OLDFNAME = "$" THEN  <<SYSTEM DEFINED FILE, NO GRP OR ACCT>>         02970000
   BEGIN   <<MOVE IN AS IS>>                                            02972000
   NEWFNAME := "$";                                                     02974000
   MOVE NEWFNAME(1) := OLDFNAME(1) WHILE AS,1;                          02976000
   BPS0 := 0;                                                           02978000
   RETURN                                                               02980000
   END;                                                                 02982000
HOMEGROUP := " ";                                              <<02326>>02984000
MOVE HOMEGROUP(1) := HOMEGROUP,(8);                            <<02326>>02986000
MOVE HOMEACCT := HOMEGROUP,(9);                                <<02326>>02988000
IF OLDFNAME = "*" THEN  <<BACK REFERENCED FILE >>              <<02326>>02990000
   BEGIN   <<MOVE IN ASTERISK AND THEN OLDNAME TO NEWNAME >>   <<02326>>02992000
   NEWFNAME := "*";                                            <<02326>>02994000
   MOVE NEWFNAME(1):= OLDFNAME(1) WHILE AN,1;                  <<02326>>02996000
   BPS0 := 0;                                                  <<02326>>02998000
   RETURN;                                                     <<02326>>03000000
   END;                                                        <<02326>>03002000
WHO(,,,,HOMEGROUP,HOMEACCT);                                            03004000
MOVE NEWFNAME := OLDFNAME WHILE ANS,0;                                  03006000
IF BPS0 = "/" THEN   <<MOVE LOCKWORD TOO>>                              03008000
   BEGIN                                                                03010000
   MOVE * := *,(1),1;                                                   03012000
   MOVE * := * WHILE ANS,0;                                             03014000
   END;                                                                 03016000
IF BPS0 = "." THEN   <<GROUP PRESENT AS WELL>>                          03018000
   BEGIN                                                                03020000
   MOVE * := *,(1),1;  <<MOVE ".">>                                     03022000
   MOVE * := * WHILE ANS,0;  <<MOVE GROUP NAME>>                        03024000
   IF BPS0 = "." THEN   <<ACCOUNT NAME PRESENT TOO>>                    03026000
      BEGIN                                                             03028000
      MOVE * := *,(1),1;                                                03030000
      MOVE * := * WHILE ANS,1;                                          03032000
      END                                                               03034000
   ELSE                                                                 03036000
      BEGIN                                                             03038000
      DEL;  <<POP POINTER TO OLDFNAME>>                                03040000
      BPS0 := ".";                                                      03042000
      TOS := TOS+1;                                                     03044000
      MOVE * := HOMEACCT WHILE AN,1;                                    03046000
      END;                                                              03048000
   BPS0 := 0;                                                           03050000
   END                                                                  03052000
ELSE   <<NEITHER GROUP OR ACCOUNT PRESENT>>                             03054000
   BEGIN                                                                03056000
   DEL;  <<POP POINTER TO OLDFNAME>>                                    03058000
   BPS0 := ".";                                                         03060000
   TOS := TOS+1;                                                        03062000
   MOVE * := HOMEGROUP WHILE AN,1;                                      03064000
   BPS0 := ".";                                                         03066000
   TOS := TOS+1;                                                        03068000
   MOVE * := HOMEACCT WHILE AN,1;                                       03070000
   BPS0 := 0;                                                           03072000
   END;                                                                 03074000
END; << QUALIFYFILENAME >>                                              03076000
$TITLE "READCAT"                                                        03078000
PROCEDURE READCAT(FILENO,RECNO,CURRENTREC,BLOCKBUFF',                   03080000
      BUFFPTR);                                                         03082000
   VALUE FILENO,RECNO;                                                  03084000
   INTEGER FILENO,CURRENTREC;                                  <<02339>>03086000
   DOUBLE RECNO;                                               <<02339>>03088000
   ARRAY BLOCKBUFF';                                                    03090000
   BYTE POINTER BUFFPTR;                                                03092000
   OPTION INTERNAL;                                                     03094000
                                                                        03096000
COMMENT -    READS A RECORD FROM THE MESSAGE CATALOG.                   03098000
   FILENO     - CATALOG FILE NUMBER.                                    03100000
   RECNO      - RECORD NUMBER. NO CHECKING DONE ON THIS NO.             03102000
   CURRENTREC - RECORD NUMBER OF FIRST RECORD IN BLOCK                  03104000
                BUFFER.                                                 03106000
   BLOCKBUFF' - DISC BUFFER RECSIZE*BLKFACTOR LONG.                     03108000
   BUFF       - BUFFER AS LARGE AS RECORD SIZE                          03110000
   CCE          EVERYTHING OK.                                          03112000
   CCL          FREADDIR FAILED.                                        03114000
;                                                                       03116000
BEGIN                                                                   03118000
                                                                        03120000
                                                                        03122000
CONDCODE := CCE;                                                        03124000
                                                                        03126000
   << GET CURRENT RECORD, SEE IF RECNO IS IN DSEG >>                    03128000
                                                                        03130000
IF (RECNO >= DOUBLE(CURRENTREC)) AND                           <<02339>>03132000
   (RECNO <= DOUBLE(CURRENTREC + BLKFACTOR-1)) THEN            <<02339>>03134000
ELSE << GO GET IT >>                                                    03136000
BEGIN                                                                   03138000
   FREADDIR(FILENO,BLOCKBUFF',RECSIZE*BLKFACTOR,               <<02339>>03140000
      RECNO/DOUBLE(BLKFACTOR));                                <<02339>>03142000
   IF <> THEN CCLRETN;                                                  03144000
                                                                        03146000
   CURRENTREC:=INTEGER((RECNO//LOGICAL(BLKFACTOR)))*BLKFACTOR; <<02339>>03148000
END;                                                                    03150000
                                                                        03152000
   << DEBLOCK FROM BUFFER >>                                            03154000
@BUFFPTR := @BLOCKBUFF'(INTEGER(RECNO-DOUBLE(CURRENTREC))      <<02339>>03156000
                         *RECSIZE) & LSL(1);                   <<02339>>03158000
                                                                        03160000
                                                                        03162000
OUTL:                                                                   03164000
END; << READCAT >>                                                      03166000
                                                                        03168000
$CONTROL SEGMENT=MAIN                                                   03170000
END. << USER >>                                                         03172000
