$CONTROL USLINIT,MAP,CODE                                               00010000
<<UTILITY - MODULE 70>>                                                 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
$THIRTY                                                                 00028000
$CONTROL SEGMENT= UTILITY1                                              00030000
BEGIN                                                                   00032000
$PAGE "  *** FIX  INFORMATION *** "                            <<04205>>00034000
<<**********************************************************>> <<04205>>00036000
<<                                                          >> <<04205>>00038000
<<                    FIX    INFORMATION                    >> <<04205>>00040000
<<                                                          >> <<04205>>00042000
<<  For each fix submitted, please describe                 >> <<04205>>00044000
<<  the fix and date below.                                 >> <<04205>>00046000
<<**********************************************************>> <<04205>>00048000
                                                               <<04205>>00050000
<<**********************************************************>> <<04205>>00052000
<<  Modified LOG to read in the new log record for type 8,  >> <<04205>>00054000
<< in which three words were added, extending the lenght to >> <<04205>>00056000
<< 34 words.  Also cleaned up a subroutine for readability. >> <<04205>>00058000
<<  February 10,1982                                        >> <<04205>>00060000
<<**********************************************************>> <<04205>>00062000
$PAGE                                                          <<04205>>00064000
                                                                        00066000
<< MISCELLANEOUS UTILITY INTRINSICS >>                                  00068000
                                                                        00070000
                                                                        00072000
<< GLOBAL DECLARATIONS >>                                               00074000
   LOGICAL STATUS = Q-1;                                                00076000
   DEFINE CC = STATUS.(6:2)#;                                           00078000
   EQUATE                                                               00080000
      CCE = 2,                                                          00082000
      CCG = 0,                                                          00084000
      CCL = 1;                                                          00086000
   DEFINE                                                               00088000
      DUPLICATE = ASSEMBLE (DUP)#,                                      00090000
       TRIPLICATE = ASSEMBLE(DUP,DUP)#,                                 00092000
      DELETE = ASSEMBLE (DEL)#;                                         00094000
   INTEGER XREG = X;                                                    00096000
   INTEGER X = X;                                              <<00.05>>00098000
   LOGICAL POINTER SPNTR0 = S-0;                                        00100000
   ARRAY DBARRAY (*) = DB+0;                                            00102000
   INTEGER S0 = S-0;                                                    00104000
   INTEGER S3 = S-3;                                                    00106000
   BYTE POINTER  BPS0 = S-0,  BPS1 = S-1;                               00108000
   DEFINE SYSTEMPROC =                                                  00110000
      ABSOLUTE (ABSOLUTE(4) +9).(6:1) = 1  #;                           00112000
   << SET X WITH PXGLOB DB DISPLACEMENT >>                              00114000
   DEFINE SETXPXGLOB =                                                  00116000
      PUSH (DL);                                                        00118000
      XREG := TOS- INTEGER (SPNTR0(-1)) #;                              00120000
   EQUATE    <<PXGLOB DISPLACEMENTS>>                                   00122000
      PXGWFLAGS = 6,                                                    00124000
      PXGWJIT = 6,                                             <<U.RAO>>00126000
      PXGWJOBIN = 3,                                                    00128000
      PXGWJOBLIST = 4;                                                  00130000
   DEFINE PXGFFLAGS = 2:4 #;                                            00132000
   DEFINE SETJIT =                                             <<U.RAO>>00134000
      SETXPXGLOB + PXGWJIT;                                    <<U.RAO>>00136000
      TOS := DBARRAY(XREG).(6:10)#;                            <<U.RAO>>00138000
   EQUATE JITJCWOFFSET = 12;                                   <<U.RAO>>00140000
<< SYSTEM INTRINSICS >>                                                 00142000
PROCEDURE HELP; OPTION EXTERNAL;                                        00144000
PROCEDURE ERRORON;                                                      00146000
   OPTION EXTERNAL;                                                     00148000
PROCEDURE ERROREXIT (INTRIN, ERRBYTE, PARAM);                           00150000
   VALUE INTRIN, ERRBYTE, PARAM;                                        00152000
   INTEGER INTRIN, ERRBYTE, PARAM;                                      00154000
   OPTION EXTERNAL;                                                     00156000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,MASK,A,B,C,D,E,           <<0U.EB>>00158000
      DEST,REPLY,BUFF,DST,IOTYPE);                             <<0U.EB>>00160000
   VALUE SETNO,MSGNO,MASK,A,B,C,D,E,DEST,REPLY,BUFF,           <<0U.EB>>00162000
      DST,IOTYPE;                                              <<0U.EB>>00164000
   LOGICAL SETNO,MSGNO,MASK,A,B,C,D,E,DEST,REPLY,BUFF,         <<0U.EB>>00166000
      DST,IOTYPE;                                              <<0U.EB>>00168000
   OPTION VARIABLE,EXTERNAL;                                   <<0U.EB>>00170000
                                                               <<0U.EB>>00172000
DOUBLE PROCEDURE CHEK (I,F,P,C,O);                             <<00.05>>00174000
   VALUE   I,F,P,C,O;                                          <<00.05>>00176000
   LOGICAL I,F,O;                                              <<00.05>>00178000
   DOUBLE  P,C;                                                <<00.05>>00180000
   OPTION  EXTERNAL,VARIABLE;                                  <<00.05>>00182000
INTEGER PROCEDURE GETDATASEG (MSIZE,DSIZE);                    <<00.05>>00184000
   VALUE   MSIZE,DSIZE;                                        <<00.05>>00186000
   INTEGER MSIZE,DSIZE;                                        <<00.05>>00188000
   OPTION  EXTERNAL;                                           <<00.05>>00190000
PROCEDURE RELDATASEG (INDX);                                   <<00.05>>00192000
   VALUE   INDX;                                               <<00.05>>00194000
   INTEGER INDX;                                               <<00.05>>00196000
   OPTION EXTERNAL;                                            <<00.05>>00198000
INTEGER PROCEDURE SETCRITICAL;                                 <<00.05>>00200000
   OPTION  EXTERNAL;                                           <<00.05>>00202000
PROCEDURE RESETCRITICAL (CRIT);                                <<00.05>>00204000
   VALUE   CRIT;                                               <<00.05>>00206000
   INTEGER CRIT;                                               <<00.05>>00208000
   OPTION  EXTERNAL;                                           <<00.05>>00210000
INTEGER PROCEDURE GETSYSBUF (NUMB,IFLAG);                      <<00.05>>00212000
   VALUE   NUMB,IFLAG;                                         <<00.05>>00214000
   INTEGER NUMB;                                               <<00.05>>00216000
   LOGICAL IFLAG;                                              <<00.05>>00218000
   OPTION  EXTERNAL;                                           <<00.05>>00220000
PROCEDURE RETURNSYSBUF (INDX);                                 <<00.05>>00222000
   VALUE   INDX;                                               <<00.05>>00224000
   INTEGER INDX;                                               <<00.05>>00226000
   OPTION  EXTERNAL;                                           <<00.05>>00228000
DOUBLE PROCEDURE ATTACHIO (DU, QM, DST, BUF, FUNC, CNT, PAR1, PAR2, FL);00230000
   VALUE DU, FL, DST, QM, BUF, FUNC, CNT, PAR1, PAR2;                   00232000
   INTEGER DU, FL, DST, QM, BUF, FUNC, CNT, PAR1, PAR2;                 00234000
   OPTION EXTERNAL;                                                     00236000
INTEGER PROCEDURE EXCHANGEDB (D);                                       00238000
   VALUE D;                                                             00240000
   INTEGER D;                                                           00242000
   OPTION EXTERNAL;                                                     00244000
                                                               <<01711>>00246000
INTEGER PROCEDURE CALENDAR;                                    <<01711>>00248000
  OPTION EXTERNAL;                                             <<01711>>00250000
                                                               <<01711>>00252000
DOUBLE PROCEDURE CLOCK;                                        <<01711>>00254000
  OPTION EXTERNAL;                                             <<01711>>00256000
                                                               <<01711>>00258000
PROCEDURE SUDDENDEATH (SYSFAILNUM);                            <<01711>>00260000
  VALUE SYSFAILNUM;                                            <<01711>>00262000
  INTEGER SYSFAILNUM;                                          <<01711>>00264000
  OPTION EXTERNAL;                                             <<01711>>00266000
                                                               <<01711>>00268000
                                                               <<04223>>00270000
PROCEDURE SOFT'DEATH (SYSFAILNUM);                             <<04223>>00272000
   VALUE SYSFAILNUM;                                           <<04223>>00274000
   INTEGER SYSFAILNUM;                                         <<04223>>00276000
   OPTION EXTERNAL;                                            <<04223>>00278000
                                                               <<04223>>00280000
INTEGER PROCEDURE GETSIR (SIRNUM);                             <<01711>>00282000
  VALUE SIRNUM;   INTEGER SIRNUM;                              <<01711>>00284000
  OPTION EXTERNAL;                                             <<01711>>00286000
                                                               <<01711>>00288000
PROCEDURE RELSIR (SIRNUM, SIRSTATE);                           <<01711>>00290000
  VALUE SIRNUM, SIRSTATE;                                      <<01711>>00292000
  INTEGER SIRNUM, SIRSTATE;                                    <<01711>>00294000
  OPTION EXTERNAL;                                             <<01711>>00296000
                                                               <<01711>>00298000
LOGICAL PROCEDURE SETSYSDB;                                    <<01711>>00300000
  OPTION EXTERNAL;                                             <<01711>>00302000
                                                               <<01711>>00304000
PROCEDURE RESETDB (DSTNUM);                                    <<01711>>00306000
  VALUE DSTNUM;   INTEGER DSTNUM;                              <<01711>>00308000
  OPTION EXTERNAL;                                             <<01711>>00310000
                                                               <<01711>>00312000
PROCEDURE AWAKE (PCBPTR, WAKEEVENT, WAITEVENT);                <<01711>>00314000
  VALUE PCBPTR, WAKEEVENT, WAITEVENT;                          <<01711>>00316000
  INTEGER PCBPTR, WAITEVENT;                                   <<01711>>00318000
  LOGICAL WAKEEVENT;                                           <<01711>>00320000
  OPTION EXTERNAL;                                             <<01711>>00322000
                                                               <<01711>>00324000
PROCEDURE DELAY (MILLISECS);                                   <<01711>>00326000
  VALUE MILLISECS;   DOUBLE MILLISECS;                         <<01711>>00328000
  OPTION EXTERNAL;                                             <<01711>>00330000
                                                               <<01711>>00332000
INTEGER PROCEDURE DEVICESTATUS(LDNUM);                         <<01794>>00334000
VALUE LDNUM;                                                   <<01794>>00336000
INTEGER LDNUM;                                                 <<01794>>00338000
OPTION EXTERNAL;                                               <<01794>>00340000
                                                               <<01794>>00342000
INTRINSIC FREAD,FWRITE,FGETINFO;                               <<00.05>>00344000
INTEGER PROCEDURE FREADX (FNUM, BUF, LEN);                              00346000
   VALUE FNUM, LEN;                                                     00348000
   INTEGER FNUM, LEN;                                                   00350000
   ARRAY BUF;                                                           00352000
   OPTION EXTERNAL;                                                     00354000
                                                                        00356000
INTEGER PROCEDURE Get'Disc'Space (ldev, number'of'sectors,     <<03506>>00358000
                                  disc'address);               <<03506>>00360000
   VALUE ldev, number'of'sectors;                              <<03506>>00362000
   INTEGER ldev;                                               <<03506>>00364000
   DOUBLE number'of'sectors, disc'address;                     <<03506>>00366000
   OPTION EXTERNAL;                                            <<03506>>00368000
                                                               <<03506>>00370000
PROCEDURE Return'Disc'Space (ldev, disc'address,               <<03506>>00372000
                             number'of'sectors);               <<03506>>00374000
   VALUE ldev, disc'address, number'of'sectors;                <<03506>>00376000
   INTEGER ldev;                                               <<03506>>00378000
   DOUBLE disc'address, number'of'sectors;                     <<03506>>00380000
   OPTION EXTERNAL;                                            <<03506>>00382000
                                                               <<03506>>00384000
$PAGE "UTILITY PROCEDURES"                                     <<00.05>>00386000
                                                                        00388000
LOGICAL PROCEDURE BINARY (STRING, LENGTH);                              00390000
   VALUE LENGTH;                                                        00392000
<< FUNCTION:                                                            00394000
   CONVERT <STRING> TO 1 BINARY WORD.  OCTAL CONVERSION IF STRING(0) =  00396000
   "%";  (SIGNED) DECIMAL CONVERSION IF STRING(0) = "+", "-", OR DIGIT. 00398000
<< INPUT PARAMETERS: >>                                                 00400000
   BYTE ARRAY STRING;        <<ASCII STRING TO BE CONVERTED>>           00402000
   INTEGER LENGTH;           <<LENGTH OF STRING>>                       00404000
<< RETURNS:                                                             00406000
   CCE- SUCCESSFUL COMPLETION.                                          00408000
   CCG- OVERFLOW, INCLUDING TOO MANY CHARACTERS.                        00410000
   CCL- ILLEGAL CHARACTER, INCLUDING "8", AND "9" FOR OCTAL.  >>        00412000
   OPTION PRIVILEGED;                                                   00414000
                                                                        00416000
BEGIN                                                                   00418000
   LOGICAL BINARYHANG := [10/62, 6/2];                                  00420000
   LOGICAL RESULT_ 0, BASE_ 10;                                         00422000
   INTEGER LIM := %71, PNTR = X;                                        00424000
<< CODE >>                                                              00426000
   ERRORON;                                                             00428000
   TOS := CHEK (BINARYHANG, %102, 3D);                                  00430000
   IF LENGTH <> 0 THEN                                                  00432000
      BEGIN                                                             00434000
      IF < THEN ERROREXIT (BINARYHANG, 8, 2);                           00436000
      TOS := (@STRING +LENGTH -1) & LSR(1);                             00438000
      ASSEMBLE (DDUP, CMP);                                             00440000
      IF < THEN TOS.(0:1) := 1;                                         00442000
      XREG := TOS;                                                      00444000
      IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (BINARYHANG, 6, 1);    00446000
      END;                                                              00448000
   XREG_ 0;                                                             00450000
   IF STRING = "%" THEN                                                 00452000
      BEGIN                                                             00454000
      LIM _ "7";                                                        00456000
      BASE_ 8;                                                          00458000
      END                                                               00460000
   ELSE IF STRING <> "+" THEN                                           00462000
         IF STRING = "-" THEN LIM := %72                                00464000
         ELSE XREG_ -1;                                                 00466000
   PUSH (STATUS);                                                       00468000
   TOS.(2:1) := 0;                                                      00470000
   SET (STATUS);                                                        00472000
   WHILE (PNTR_ PNTR+1) < LENGTH DO                                     00474000
      BEGIN                                                             00476000
      TOS_ RESULT*BASE;                                                 00478000
      IF CARRY THEN GOTO SETOVERFLOW;                                   00480000
      TOS_ STRING(PNTR);                                                00482000
      IF <= THEN GOTO SETBADCHAR;                                       00484000
      DUPLICATE;                                                        00486000
      IF TOS > LIM THEN GOTO SETBADCHAR;                                00488000
      RESULT_ TOS.(12:4)+TOS;                                           00490000
      IF CARRY THEN GOTO SETOVERFLOW;                          <<00.04>>00492000
      END;                                                              00494000
   IF LIM >= "9" THEN    <<A DECIMAL CONVERSION>>                       00496000
      IF RESULT > 32768 THEN GOTO SETOVERFLOW                           00498000
      ELSE IF = THEN    <<BETTER BE NEGATIVE>>                          00500000
            IF LIM = "9" THEN GOTO SETOVERFLOW                          00502000
            ELSE   <<SMALLEST NEGATIVE NUMBER>>                         00504000
         ELSE IF LIM = %72 THEN RESULT_ -RESULT;                        00506000
   BINARY_ RESULT;                                                      00508000
   TOS := CCE;                                                          00510000
EXIT:                                                                   00512000
   CC := TOS;                                                           00514000
   ERROREXIT (BINARYHANG, 0, 0);                                        00516000
SETOVERFLOW:                                                            00518000
   TOS := CCG;                                                          00520000
   GOTO EXIT;                                                           00522000
SETBADCHAR:                                                             00524000
   TOS := CCL;                                                          00526000
   GOTO EXIT;                                                           00528000
   HELP;  << CALL FOR LINKING TO DEBUGER >>                             00530000
END  <<BINARY>>;                                                        00532000
                                                                        00534000
                                                                        00536000
DOUBLE PROCEDURE DBINARY(STRING,LENGTH);                                00538000
   VALUE LENGTH;  BYTE ARRAY STRING; INTEGER LENGTH;                    00540000
   OPTION PRIVILEGED;                                                   00542000
BEGIN                                                                   00544000
      LOGICAL STAT = Q-1;                                               00546000
      INTEGER TOP = S-0;                                                00548000
      INTEGER I := 0;                                                   00550000
      DOUBLE TOPD = S-1;                                                00552000
      LOGICAL HANGPARM := %11202;                                       00554000
   ERRORON;                                                             00556000
      TOS := CHEK(HANGPARM,%202, 3D);                                   00558000
      BEGIN IF LENGTH < 0 THEN ERROREXIT (HANGPARM, 8, 2);              00560000
            IF LENGTH = 0 THEN                                          00562000
                 BEGIN  TOS := 0D;                                      00564000
                        GO TO SKIP;                                     00566000
                 END;                                                   00568000
            IF LENGTH > 12 THEN GO TO ERR1;                             00570000
            ASSEMBLE(DUP);                                              00572000
      IF TOS < (XREG := (@STRING+LENGTH-1)&LSR(1)) THEN XREG.(0:1) := 1;00574000
            IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (HANGPARM, 6, 1);00576000
      END;                                                              00578000
      TOS := 0D;                                                        00580000
      IF STRING = "%" THEN                                              00582000
      BEGIN IF (LENGTH = 12) AND (STRING(1) > %63) THEN GO TO ERR1;     00584000
            WHILE (I:=I+1) < LENGTH DO                                  00586000
            BEGIN ASSEMBLE(DLSL 3);                                     00588000
                  TOS := LOGICAL(STRING(I)) - %60;                      00590000
                  IF (TOP>7) OR (TOP<0) THEN GO TO ERR2;                00592000
                  ASSEMBLE(OR)                                          00594000
            END                                                         00596000
      END                                                               00598000
      ELSE                                                              00600000
      BEGIN PUSH(STATUS);                                               00602000
            ASSEMBLE(TRBC 2);                                           00604000
            SET(STATUS);                                                00606000
            IF (STRING <> "+") AND (STRING <> "-") THEN I := I - 1;     00608000
            WHILE (I:=I+1) < LENGTH DO                                  00610000
            BEGIN IF TOPD >= %2000000000D THEN GO TO ERR1;              00612000
                  ASSEMBLE(DLSL 1; DDUP; DLSL 2; DADD);                 00614000
                  IF OVERFLOW THEN GO TO ERR1;                          00616000
                  TOS := 0;                                             00618000
                  TOS := LOGICAL(STRING(I)) - %60;                      00620000
                  IF (TOP>9) OR (TOP<0) THEN GO TO ERR2;                00622000
                  ASSEMBLE(DADD);                                       00624000
                  IF OVERFLOW THEN                                      00626000
                  BEGIN IF TOPD <> %20000000000D THEN GO TO ERR1;       00628000
                        IF STRING <> "-" THEN GO TO ERR1;               00630000
                        GO TO SKIP                                      00632000
                  END                                                   00634000
            END;                                                        00636000
            IF STRING = "-" THEN ASSEMBLE(DNEG);                        00638000
      END;                                                              00640000
SKIP: DBINARY := TOS;                                                   00642000
      STAT.(6:2) := 2;                                                  00644000
EXIT:                                                                   00646000
   ERROREXIT (HANGPARM, 0, 0);                                          00648000
ERR1: STAT.(6:2) := 0;                                                  00650000
   GOTO EXIT;                                                           00652000
ERR2: STAT.(6:2) := 1;                                                  00654000
   GOTO EXIT;                                                           00656000
END  <<DBINARY>>;                                                       00658000
                                                                        00660000
                                                                        00662000
                                                                        00664000
                                                                        00666000
INTEGER PROCEDURE ASCII (WORD, BASE, STRING);                           00668000
   VALUE WORD, BASE;                                                    00670000
<< FUNCTION:                                                            00672000
   CONVERT <WORD> TO ASCII.  FOR BASE= 10, PERFORM SIGNED DECIMAL       00674000
   CONVERSION (STRING(0) = "-", IF NECESSARY).  >>                      00676000
<< INPUT PARAMETERS: >>                                                 00678000
   LOGICAL WORD;             <<WORD TO BE CONVERTED>>                   00680000
   INTEGER BASE;             <<8 (OCTAL), OR 10 (SIGNED DECIMAL)>>      00682000
<< OUTPUT PARAMETERS: >>                                                00684000
   BYTE ARRAY STRING;        <<RESULT. PROVIDE ROOM FOR AT LEAST 6 BYT>>00686000
   OPTION PRIVILEGED;                                                   00688000
                                                                        00690000
BEGIN                                                                   00692000
   LOGICAL ASCIIHANG := [10/63, 6/3];                                   00694000
   BYTE ARRAY TEMP (0:5) = Q;                                           00696000
   INTEGER WORDD = WORD;                                                00698000
   LOGICAL FLAGS := 0;                                                  00700000
   DEFINE START = FLAGS.(15:1) #;                                       00702000
   DEFINE RTJUST = FLAGS.(14:1) #;                                      00704000
   INTEGER LENGTH = Q-7;                                                00706000
                                                                        00708000
                                                                        00710000
SUBROUTINE CHEKIT (LEN);                                                00712000
   VALUE LEN;                                                           00714000
   INTEGER LEN;                                                         00716000
BEGIN                                                                   00718000
   TOS := CHEK (ASCIIHANG, %103, %60D);                                 00720000
      BEGIN                                                             00722000
      TOS := (@STRING +S3 -1) & LSR(1);                                 00724000
      ASSEMBLE (DDUP, CMP);                                             00726000
      IF < THEN TOS.(0:1) := 1;                                         00728000
      XREG := TOS;                                                      00730000
      IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (ASCIIHANG, 6, 3);     00732000
      END;                                                              00734000
   END    <<SUBROUTINE CHELIT>>;                                        00736000
<< MAIN CODE >>                                                         00738000
   ERRORON;                                                             00740000
   IF BASE <> 8 THEN                                                    00742000
      BEGIN                                                             00744000
      IF BASE <> 10 THEN                                                00746000
         BEGIN    <<RT JUSTIFY REQUEST>>                                00748000
         IF BASE <> -10 THEN ERROREXIT (ASCIIHANG, 8, 2);               00750000
         RTJUST := TRUE;                                                00752000
         BASE := 10;                                                    00754000
         END;                                                           00756000
      IF WORDD < 0 THEN                                                 00758000
         BEGIN                                                          00760000
         PUSH (STATUS);                                                 00762000
         ASSEMBLE (TRBC 2);                                             00764000
         SET (STATUS);                                                  00766000
         WORDD_ -WORDD;                                                 00768000
         IF OVERFLOW THEN                                               00770000
            BEGIN                                                       00772000
            MOVE TEMP := "-32768";                                      00774000
            XREG := 0;                                                  00776000
            GOTO SETUP;                                                 00778000
            END;                                                        00780000
         START := TRUE;                                                 00782000
         END;                                                           00784000
      TOS_ WORDD;                                                       00786000
      XREG := 6;                                                        00788000
      DO BEGIN                                                          00790000
         TOS := BASE;                                                   00792000
         ASSEMBLE (DIV, DECX);                                          00794000
         TEMP(XREG) := TOS +%60;                                        00796000
         ASSEMBLE (TEST);                                               00798000
         END                                                            00800000
      UNTIL =;                                                          00802000
      IF START THEN TEMP (XREG := XREG -1) := "-";                      00804000
SETUP:                                                                  00806000
      << XREG = LEFT BYTE OF RESULT IN TEMP >>                          00808000
      LENGTH := 6 -XREG;                                                00810000
      TOS := @STRING;    <<SETUP FOR MOVE>>                             00812000
      TOS := @TEMP;                                                     00814000
      IF RTJUST THEN                                                    00816000
         BEGIN    <<RT JUSTIFICATION>>                                  00818000
         TOS := TOS +5;                                                 00820000
         TOS := -LENGTH;                                                00822000
         TOS := S0 +2;    <<(FOR BOUND. CHECK)>>                        00824000
         END                                                            00826000
      ELSE                                                              00828000
         BEGIN    <<LEFT JUSTIFY>>                                      00830000
         TOS := TOS +XREG;                                              00832000
         TOS := LENGTH;                                                 00834000
         TOS := S0;                                                     00836000
         END;                                                           00838000
      << S-0 = LENGTH 4 BOUND. CHECK >>                                 00840000
      << (S-3):(S-1) = MOVE SETUP >>                                    00842000
      CHEKIT (*);                                                       00844000
      ASSEMBLE (MVB);                                                   00846000
      END                                                               00848000
   ELSE                                                                 00850000
      BEGIN    <<OCTAL>>                                                00852000
      CHEKIT (6);                                                       00854000
      XREG := 5;                                                        00856000
      LENGTH := 1;                                                      00858000
      TOS_ WORD;                                                        00860000
      DO BEGIN                                                          00862000
         DUPLICATE;                                                     00864000
         TOS := TOS LAND 7;                                             00866000
         IF <> THEN LENGTH := 6 -XREG;                                  00868000
         STRING (XREG) := TOS + %60;                                    00870000
         TOS := TOS & LSR(3);                                           00872000
         XREG := XREG -1;                                               00874000
         END                                                            00876000
      UNTIL <;                                                          00878000
      END;                                                              00880000
                                                                        00882000
   ERROREXIT (ASCIIHANG, 0, 0);                                         00884000
END  <<ASCII>>;                                                         00886000
                                                                        00888000
                                                                        00890000
INTEGER PROCEDURE DASCII(WORD,BASE,STRING);                             00892000
   VALUE WORD,BASE;                                                     00894000
   DOUBLE WORD; INTEGER BASE;                                           00896000
   BYTE ARRAY STRING;                                                   00898000
   OPTION PRIVILEGED;                                                   00900000
BEGIN LOGICAL SNFLG := FALSE;                                           00902000
      INTEGER J;                                                        00904000
      BYTE ARRAY LSTRING(0:10);                                         00906000
      LOGICAL HANGPARM := %11304;                                       00908000
      INTEGER LENGTH = Q-8;                                             00910000
      LOGICAL K=S-0;                                                    00912000
      DOUBLE TOP=S-1;                                                   00914000
   ERRORON;                                                             00916000
      J := 11;                                                          00918000
      TOS := WORD;                                                      00920000
      IF BASE = 8 THEN                                                  00922000
      BEGIN LENGTH := 1;                                                00924000
            WHILE (J := J-1) >= 0 DO                                    00926000
            BEGIN TOS := K LAND 7;                                      00928000
                  IF <> THEN LENGTH := 11-J;                            00930000
                  TOS := TOS + %60;                                     00932000
                  LSTRING(J) := TOS;                                    00934000
                  TOS := TOS & DLSR(3);                                 00936000
            END;                                                        00938000
      TOS := 11;                                                        00940000
            J := J + 1;                                                 00942000
            GO TO FINISH                                                00944000
      END;                                                              00946000
      IF BASE <> 10 THEN ERROREXIT (HANGPARM, 8, 2);                    00948000
      ASSEMBLE(DTST);                                                   00950000
      IF = THEN                                                         00952000
      BEGIN LSTRING(10) := %60;                                         00954000
            TOS := (LENGTH := 1);                                       00956000
            J:=10;                                                      00958000
            GO TO FINISH                                                00960000
      END;                                                              00962000
      IF < THEN                                                         00964000
      BEGIN SNFLG := TRUE;                                              00966000
            IF TOP <> %20000000000D THEN ASSEMBLE(DNEG);                00968000
      END;                                                              00970000
LOOP:                                                                   00972000
      J := J - 1;                                                       00974000
      ASSEMBLE(ZERO,CAB);                                               00976000
      TOS := 10;                                                        00978000
      ASSEMBLE(DIVL,CAB);                                               00980000
      TOS := 10;                                                        00982000
      ASSEMBLE(DIVL);                                                   00984000
      LSTRING(J) := TOS + %60;                                          00986000
      ASSEMBLE(DTST);                                                   00988000
      IF = THEN                                                         00990000
      BEGIN IF SNFLG THEN                                               00992000
            BEGIN J := J - 1;                                           00994000
                  LSTRING(J) := "-";                                    00996000
            END;                                                        00998000
            TOS := (LENGTH := 11 -J);                                   01000000
FINISH:                                                                 01002000
      TOS := CHEK (HANGPARM, %103, %61D);                               01004000
      BEGIN ASSEMBLE(DUP);                                              01006000
            IF TOS < (XREG := (@STRING+LENGTH-1) & LSR(1) )             01008000
               THEN XREG.(0:1) := 1;                                    01010000
            IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (HANGPARM, 6, 3);01012000
      END;                                                              01014000
            MOVE STRING := LSTRING (J), (S0);                           01016000
            ERROREXIT (HANGPARM, 0, 0);                                 01018000
      END;                                                              01020000
      GO TO LOOP                                                        01022000
END   <<DASCII>>;                                                       01024000
PROCEDURE CLEAN'MESSAGE(MSG,LEN);                              <<01.01>>01026000
<< AVOIDS UNDESIRABLE ESCAPE SEQUENCES AND CONTROL CHARACTERS ><<01.01>>01028000
<< HAVING UNWANTED EFFECTS WHEN DISPLAYED BY A TELL OR TELLOP ><<01.01>>01030000
<< COMMAND, OR A PRINTOP OR PRINTOPREPLY INTRINSIC,           ><<01.01>>01032000
<< TO A 2640A, 2640B, 2644A OR 2645A OR TO A GE TERMINET.     ><<01.01>>01034000
<< MAY REQUIRE MODIFICATION FOR MULTILINGUAL CAPABILITY.      ><<01.01>>01036000
VALUE LEN;                                                     <<01.01>>01038000
INTEGER LEN;  << LENGTH OF MSG IN BYTES >>                     <<01.01>>01040000
BYTE ARRAY MSG;   <<ALWAYS BEGINS ON WD BDY, MUST END WITH CR>><<U.RAO>>01042000
OPTION PRIVILEGED,UNCALLABLE;                                  <<01.01>>01044000
BEGIN                                                          <<01.01>>01046000
   BYTE POINTER MSG'CHAR;    << POINTS TO FIRST CHARACTER IN MS<<01.01>>01048000
   BYTE POINTER CHAR;        << POINTS TO CURRENT CHARACTER >> <<01.01>>01050000
   INTEGER INDEX;            << INDEX OF CURRENT CHARACTER >>  <<01.01>>01052000
   LOGICAL DONE;             << LOOP CONTROL FLAG >>           <<01.01>>01054000
   BYTE ARRAY TEXT(0:LEN);   << HOLDS MSG TO INSURE ROOM FOR CR<<01.01>>01056000
   EQUATE                                                      <<01.01>>01058000
      BELL        =%7,                                         <<01.01>>01060000
      SHIFT'IN    =%17,                                        <<01.01>>01062000
      SHIFT'OUT   =%16,                                        <<01.01>>01064000
      CR'ESC      =%006433,                                    <<01.01>>01066000
      CR          =%15,                                        <<01.01>>01068000
      NUL         =%0,                                         <<01.01>>01070000
      ESC         =%33;                                        <<01.01>>01072000
   DEFINE                                                      <<01.01>>01074000
      SPACE          =" "#,                                    <<01.01>>01076000
      ALT'CHAR'SET   =")"#,                                    <<01.01>>01078000
      DISPLAY'ENHANCE="&d"#;                                   <<01.01>>01080000
                                                               <<01.01>>01082000
   << SCREEN OUT MSB OF EACH BYTE IN TEXT >>                   <<01.01>>01084000
   @MSG'CHAR := @MSG;                                          <<U.RAO>>01086000
   MOVE TEXT:=MSG'CHAR, (LEN);  << PUT MSG IN LOCAL ARRAY >>   <<01.01>>01088000
   @CHAR:=@TEXT;                                               <<01.01>>01090000
   WHILE (@CHAR < @TEXT(LEN)) DO                               <<01.01>>01092000
   BEGIN  << SCREEN OUT MSB OF EACH BYTE IN TEXT >>            <<01.01>>01094000
      CHAR:=BYTE(LOGICAL(CHAR) LAND %177);                     <<01.01>>01096000
      @CHAR:=@CHAR+1;                                          <<01.01>>01098000
   END;                                                        <<01.01>>01100000
   TEXT(LEN):=CR;  << CR AT END TO STOP SCANS >>               <<01.01>>01102000
                                                               <<01.01>>01104000
   << CHECK FOR ESCAPE SEQUENCE(S) >>                          <<01.01>>01106000
   @CHAR:=@TEXT;                                               <<01.01>>01108000
   DONE:=FALSE;                                                <<01.01>>01110000
   DO                                                          <<01.01>>01112000
   BEGIN                                                       <<01.01>>01114000
      SCAN CHAR UNTIL CR'ESC, 1;                               <<01.01>>01116000
      @CHAR:=TOS;                                              <<01.01>>01118000
      IF CARRY THEN                                            <<01.01>>01120000
      BEGIN  << CR FOUND >>                                    <<01.01>>01122000
         IF @CHAR >= @TEXT(LEN) THEN                           <<01.01>>01124000
            DONE:=TRUE;  << GOT A CR AT END OF TEXT >>         <<01.01>>01126000
      END                                                      <<01.01>>01128000
      ELSE  << GOT ESC ... >>                                  <<01.01>>01130000
         IF @CHAR=@TEXT(LEN-1) THEN  << GOT ESC AT END OF MSG ><<01.01>>01132000
            MSG'CHAR(@CHAR-@TEXT):=SPACE                       <<01.01>>01134000
         ELSE                                                  <<01.01>>01136000
            IF CHAR(1) = DISPLAY'ENHANCE THEN  << OK >>        <<01.01>>01138000
            ELSE                                               <<01.01>>01140000
               IF CHAR(1) = ALT'CHAR'SET THEN  << OK >>        <<01.01>>01142000
               ELSE  << UNACCEPTABLE ESCAPE SEQUENCE >>        <<01.01>>01144000
                  MSG'CHAR(@CHAR-@TEXT):=SPACE;                <<01.01>>01146000
      IF (@CHAR:=@CHAR+1) >= @TEXT(LEN) THEN DONE:=TRUE;       <<01.01>>01148000
   END                                                         <<01.01>>01150000
   UNTIL DONE;                                                 <<01.01>>01152000
                                                               <<01.01>>01154000
   << CHECK FOR CONTROL CHARACTER(S) >>                        <<01.01>>01156000
   INDEX:=0;                                                   <<01.01>>01158000
   @CHAR:=@TEXT;                                               <<01.01>>01160000
   WHILE INDEX < LEN DO                                        <<01.01>>01162000
   BEGIN                                                       <<01.01>>01164000
      WHILE CHAR(INDEX) >= SPACE                               <<01.01>>01166000
      AND INDEX < LEN-1 DO                                     <<01.01>>01168000
         INDEX:=INDEX+1;                                       <<01.01>>01170000
      IF CHAR(INDEX) < BYTE(SPACE)                             <<01.01>>01172000
      AND CHAR(INDEX) <> BYTE(NUL)                             <<01.01>>01174000
      AND CHAR(INDEX) <> BYTE(ESC)                             <<01.01>>01176000
      AND CHAR(INDEX) <> BYTE(BELL)                            <<01.01>>01178000
      AND CHAR(INDEX) <> BYTE(SHIFT'IN)                        <<01.01>>01180000
      AND CHAR(INDEX) <> BYTE(SHIFT'OUT) THEN                  <<01.01>>01182000
         MSG'CHAR(INDEX):=SPACE;  << UNACCEPTABLE CTRL CHAR >> <<01.01>>01184000
      << NEXT CHARACTER >>                                     <<01.01>>01186000
      INDEX:=INDEX+1;                                          <<01.01>>01188000
   END;                                                        <<01.01>>01190000
END;  << CLEAN'MESSAGE >>                                      <<01.01>>01192000
                                                               <<KS.02>>01194000
PROCEDURE ZEROBYTE4GENMSG(MESSAGE,LENGTH,OP);                  <<KS.02>>01196000
VALUE LENGTH,OP;                                               <<KS.02>>01198000
LOGICAL OP;                                                             01200000
INTEGER LENGTH;                                                <<KS.02>>01202000
ARRAY MESSAGE;                                                 <<KS.02>>01204000
OPTION PRIVILEGED,UNCALLABLE;                                  <<KS.02>>01206000
BEGIN                                                          <<KS.02>>01208000
   INTEGER TEMPLEN;                                            <<01458>>01210000
   BYTE ARRAY TEMPPTR(*) = Q;                                  <<01458>>01212000
   << TEMPPTR MUST BE THE LAST LOCAL DECLARATION.  ITS SPACE >><<01458>>01214000
   << IS ALLOCATED BY THE "ADDS 0" INSTRUCTION.              >><<01458>>01216000
   TEMPLEN:=IF LENGTH<0 THEN -LENGTH ELSE LENGTH&ASL(1);       <<KS.02>>01218000
   TOS:=(TEMPLEN&ASR(1))+1;<<1 EXTRA WORD FOR ZERO TERMINATOR>><<KS.02>>01220000
   ASSEMBLE(ADDS 0);                                           <<KS.02>>01222000
   TOS:=@TEMPPTR;                                              <<KS.02>>01224000
   TOS:=@MESSAGE&LSL(1);                                       <<KS.02>>01226000
   MOVE *:=*,(TEMPLEN),2; <<MOVE MESSAGE INTO STACK ARRAY>>    <<KS.02>>01228000
   BPS0:=0; <<TERMINATE MESSAGE WITH ZERO BYTE FOR GENMSG>>    <<KS.02>>01230000
   GENMSG(-1,@TEMPPTR,,,,,,,IF OP THEN 0 ELSE -2);             <<KS.02>>01232000
   PUSH(STATUS); <<RETURN GENMSG'S STATUS>>                    <<KS.02>>01234000
   TOS:=TOS.(6:2);                                             <<KS.02>>01236000
   CC:=TOS;                                                    <<KS.02>>01238000
END;                                                           <<KS.02>>01240000
                                                                        01242000
                                                                        01244000
PROCEDURE PRINT (MESSAGE, LENGTH, TYPE);                                01246000
   VALUE LENGTH, TYPE;                                                  01248000
   ARRAY MESSAGE;                                                       01250000
   INTEGER LENGTH, TYPE;                                                01252000
   OPTION PRIVILEGED;                                                   01254000
BEGIN                                                                   01256000
   ENTRY PRINT';                                                        01258000
   LOGICAL PRINTHANG := [10/65, 6/3];                                   01260000
PRINT':                                                                 01262000
   <<CHECK PARAMETER BOUNDS AND DB>>                                    01264000
   ERRORON;                                                             01266000
   TOS := CHEK (PRINTHANG, 3, 2D);                                      01268000
   IF LENGTH <> 0 THEN                                                  01270000
      BEGIN                                                             01272000
      XREG := @MESSAGE +                                                01274000
         (IF LENGTH < 0 THEN (-LENGTH+1) & ASR(1) ELSE LENGTH) -1;      01276000
      IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (PRINTHANG, 6, 1);     01278000
      END;                                                              01280000
   IF SYSTEMPROC THEN                                          <<KS.02>>01282000
   BEGIN                                                       <<KS.02>>01284000
      ZEROBYTE4GENMSG(MESSAGE,LENGTH,FALSE);                   <<KS.02>>01286000
      PUSH(STATUS);                                            <<KS.02>>01288000
   END                                                         <<KS.02>>01290000
   ELSE                                                                 01292000
      BEGIN    << MAIN OR USER: GO THRU FILE SYS >>                     01294000
      FWRITE (2, MESSAGE, LENGTH, TYPE);                                01296000
      PUSH (STATUS);                                                    01298000
      END;                                                              01300000
   TOS:=TOS.(6:2);                                             <<KS.02>>01302000
   CC := TOS;                                                           01304000
   ERROREXIT (PRINTHANG, 0, 0);                                         01306000
   END  <<PRINT>>;                                                      01308000
                                                                        01310000
                                                                        01312000
PROCEDURE PRINTOP (MESSAGE, LENGTH, TYPE);                              01314000
   VALUE LENGTH, TYPE;                                                  01316000
   ARRAY MESSAGE;                                                       01318000
   INTEGER LENGTH, TYPE;                                                01320000
   OPTION PRIVILEGED;                                                   01322000
BEGIN                                                                   01324000
   LOGICAL PRINTOPHANG := [10/66, 6/3];                                 01326000
   <<CHECK PARAMETER BOUNDS AND DB>>                                    01328000
   ERRORON;                                                             01330000
   TOS := CHEK (PRINTOPHANG, 3, 2D);                                    01332000
   IF LENGTH <> 0 THEN                                                  01334000
      BEGIN                                                             01336000
      XREG := @MESSAGE +                                                01338000
         (IF LENGTH < 0 THEN (-LENGTH+1) & ASR(1) ELSE LENGTH) -1;      01340000
      IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (PRINTOPHANG, 6, 1);   01342000
      END;                                                              01344000
   IF LENGTH < 0 THEN                                          <<01458>>01346000
      BEGIN                                                    <<01458>>01348000
      IF LENGTH < -72 THEN LENGTH := -72;                      <<01458>>01350000
      END                                                      <<01458>>01352000
   ELSE                                                        <<01458>>01354000
      IF LENGTH > 36 THEN LENGTH := 36;                        <<01458>>01356000
   TOS := LENGTH;                                                       01358000
   IF < THEN TOS := -TOS                                                01360000
   ELSE TOS := TOS & ASL(1);                                            01362000
   CLEAN'MESSAGE(MESSAGE,S0);                                  <<01.01>>01364000
   ZEROBYTE4GENMSG(MESSAGE,LENGTH,TRUE);                       <<KS.02>>01366000
   IF <> THEN CC := CCL                                        <<0U.EB>>01368000
   ELSE                                                                 01370000
      CC := CCE;                                                        01372000
                                                               <<KS.04>>01374000
   ERROREXIT (PRINTOPHANG, 0, 0);                                       01376000
   END  <<PRINTOP>>;                                                    01378000
                                                                        01380000
                                                                        01382000
INTEGER PROCEDURE READ (MESSAGE, EXPECTEDL);                            01384000
   VALUE EXPECTEDL;                                                     01386000
   ARRAY MESSAGE;                                                       01388000
   INTEGER EXPECTEDL;                                                   01390000
   OPTION PRIVILEGED;                                                   01392000
BEGIN                                                                   01394000
   ENTRY READX;                                                         01396000
   LOGICAL X := FALSE;    <<READX FLAG>>                                01398000
EQUATE CONSOLE=%1074;  <<SYS GLOBAL CELL CONTAINING CONSOLE#>> <<00552>>01400000
   LOGICAL READHANG := [10/64, 6/2];                                    01402000
   <<CHECK PARAMETER BOUNDS & DB>>                                      01404000
                                                                        01406000
   GOTO START;                                                          01408000
                                                                        01410000
READX:                                                                  01412000
   X := TRUE;                                                           01414000
                                                                        01416000
START:                                                                  01418000
   ERRORON;                                                             01420000
   TOS := CHEK (READHANG, %102, 2D);                                    01422000
   IF EXPECTEDL <> 0 THEN                                               01424000
      BEGIN                                                             01426000
      XREG := @MESSAGE +                                                01428000
         (IF EXPECTEDL < 0 THEN (-EXPECTEDL+1)&ASR(1) ELSE EXPECTEDL)-1;01430000
      IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (READHANG, 6, 1);      01432000
      END;                                                              01434000
   IF SYSTEMPROC THEN                                                   01436000
      BEGIN    << SYS PROCESS: DO ATTACHIO DIRECTLY >>                  01438000
                                                               <<00552>>01440000
TOS:=ATTACHIO(ABSOLUTE(CONSOLE).(8:8),0,0,@MESSAGE,            <<00552>>01442000
            0, EXPECTEDL, 0, 0, 1);                                     01444000
      ASSEMBLE (TEST);                                                  01446000
      IF < THEN TOS := -TOS;                                            01448000
      ASSEMBLE (XCH);                                                   01450000
      TOS := IF TOS.(13:3) = 2 THEN CCG                                 01452000
            ELSE IF > THEN CCL ELSE CCE;                                01454000
      END                                                               01456000
   ELSE                                                                 01458000
      BEGIN    << MAIN OR USER: USE FILE SYS >>                         01460000
      TOS := 0;    <<SETUP FOR FREAD OR FREADX CALL>>                   01462000
      TOS := 1;                                                         01464000
      TOS := @MESSAGE;                                                  01466000
      TOS := EXPECTEDL;                                                 01468000
      TOS := IF X THEN FREADX (*, *, *) ELSE FREAD (*, *, *);           01470000
      PUSH (STATUS);    <<RETURN STATUS>>                               01472000
      TOS := TOS.(6:2);                                                 01474000
      END;                                                              01476000
   CC := TOS;                                                           01478000
   READ := TOS;    <<LENGTH>>                                           01480000
   ERROREXIT (READHANG, 0, 0);                                          01482000
   END  <<READ>>;                                                       01484000
                                                                        01486000
                                                                        01488000
INTEGER PROCEDURE SEARCH (TARGET, LENGTH, DICT, DEFN);                  01490000
   VALUE LENGTH;                                                        01492000
<< FUNCTION:                                                            01494000
   SEARCH <DICT> FOR <TARGET>.  >>                                      01496000
<< INPUT PARAMETERS: >>                                                 01498000
   BYTE ARRAY TARGET;        <<STRING TO SEARCH FOR>>                   01500000
   INTEGER LENGTH;           <<LENGTH OF <TARGET>.>>                    01502000
   BYTE ARRAY DICT;          <<"DICTIONARY" FOR SEARCH.  EACH ENTRY:    01504000
      1. BYTE LENGTH OF ITEMS 1+2+3+4.  (1 BYTE)                        01506000
      2. BYTE LENGTH OF ITEM 2. (1 BYTE)                                01508000
      3. THE "WORD" FOR THIS ENTRY.                                     01510000
      4. (OPTIONAL) A CALLER-RELEVANT "DEFINITION" (>= 0 BYTES LONG).   01512000
      LAST ENTRY HAS 0 ENTRY LENGTH. >>                                 01514000
<< OUTPUT PARAMETER: >>                                                 01516000
   BYTE POINTER DEFN;        <<(OPTIONAL) BYTE ADDR OF ITEM 4>>         01518000
   OPTION VARIABLE, PRIVILEGED;                                         01520000
                                                                        01522000
BEGIN                                                                   01524000
   LOGICAL SEARCHHANG := [10/70, 6/5];                                  01526000
   LOGICAL PARMCOUNT = Q-4;                                             01528000
   LOGICAL LLENGTH = LENGTH;                                            01530000
   BYTE POINTER PNTR = DICT;                                            01532000
   INTEGER COUNT_ 0;                                                    01534000
   INTEGER X=      X,                                          <<09.KM>>01536000
           S0=     S-0,                                        <<09.KM>>01538000
           UBOUND= SEARCH-1;                                   <<09.KM>>01540000
   DEFINE COMPARE2 = ASSEMBLE (CMPB 2)#;                                01542000
<< CODE >>                                                              01544000
   ERRORON;                                                             01546000
   TOS := CHEK (SEARCHHANG, %104, %263D, , 1);                          01548000
   IF LLENGTH > 0 THEN                                                  01550000
      BEGIN                                                             01552000
      IF LLENGTH > 254 THEN ERROREXIT (SEARCHHANG, 8, 2);               01554000
      TOS := (@TARGET+LENGTH-1) &LSR(1);                                01556000
      ASSEMBLE (DDUP, CMP);                                             01558000
      IF < THEN TOS.(0:1) := 1;                                         01560000
      XREG := TOS;                                                      01562000
      IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (SEARCHHANG, 6, 1);    01564000
      END;                                                              01566000
   TOS:=TOS:=@PNTR&LSR(1);                                     <<09.KM>>01568000
   IF TOS>@S0 THEN TOS.(0:1):=1;       <<WD ADR OF CUR ENTRY>> <<09.KM>>01570000
                                                               <<09.KM>>01572000
   WHILE PNTR<>0 DO                                            <<09.KM>>01574000
      BEGIN                                                             01576000
      COMMENT:                                                 <<09.KM>>01578000
        S-0 = WORD-ADDR OF CURRENT ENTRY.                      <<09.KM>>01580000
                                                               <<09.KM>>01582000
        ADDRESS OF NEXT ENTRY MUST LIE BETWEEN CURRENT ENTRY   <<09.KM>>01584000
        AND CALLING SEQUENCE ("UBOUND").  RANGE CHECK IS       <<09.KM>>01586000
        NECESSARY DUE TO POSSIBLE INVALID WRAP-AROUND INTO     <<09.KM>>01588000
        DB-MINUS AREA DURING BYTE-WORD ADDRESS CONVERSION;     <<09.KM>>01590000
                                                               <<09.KM>>01592000
      TOS:=TOS:=@PNTR(PNTR)&LSR(1);                            <<09.KM>>01594000
      IF TOS>@S0 THEN TOS.(0:1):=1;    <<WD ADR OF NEXT ENTRY>><<09.KM>>01596000
      IF NOT (TOS<=TOS<=@UBOUND)                               <<09.KM>>01598000
         THEN ERROREXIT(SEARCHHANG,6,3);                       <<09.KM>>01600000
      TOS:=X;                          <<WD ADR OF NEXT ENTRY>><<09.KM>>01602000
      COUNT_ COUNT+1;                                                   01604000
      IF INTEGER(PNTR(1)) = LENGTH THEN                                 01606000
         BEGIN                                                          01608000
         TOS_ @PNTR(XREG+1);                                            01610000
         TOS_ @TARGET;                                                  01612000
         TOS_ LENGTH;                                                   01614000
         COMPARE2;                                                      01616000
         IF = THEN                                                      01618000
            BEGIN                                                       01620000
            IF PARMCOUNT THEN @DEFN := TOS;                             01622000
            SEARCH_ COUNT;                                              01624000
            ERROREXIT (SEARCHHANG, 0, 0);                               01626000
            END;                                                        01628000
         DELETE;                                                        01630000
         END;                                                           01632000
      @PNTR:=@PNTR(PNTR);              <<IN BNDS, SEE 1ST TST>><<09.KM>>01634000
      END;                                                              01636000
   SEARCH_ 0;                                                           01638000
   ERROREXIT (SEARCHHANG, 0, 0);                                        01640000
END  <<SEARCH>>;                                                        01642000
                                                                        01644000
                                                                        01646000
PROCEDURE WHO                                                           01648000
   (MODE, CAPABILITY, LATTR, USERN, GROUPN, ACCTN, HOMEN, TERMNUM);     01650000
   LOGICAL MODE, TERMNUM;                                               01652000
   DOUBLE CAPABILITY, LATTR;                                            01654000
   BYTE ARRAY USERN, GROUPN, ACCTN, HOMEN;                              01656000
   OPTION VARIABLE, PRIVILEGED;                                         01658000
BEGIN                                                                   01660000
   LOGICAL WHOHANG := [10/69, 6/9];                                     01662000
   LOGICAL PARMCNT = Q-4;                                               01664000
   INTEGER ARRAY BPARMS (*) = Q-9;                                      01666000
   INTEGER CAPAD = Q-11;                                                01668000
   INTEGER LATAD = Q-10;                                                01670000
   LOGICAL LS0 = S-0;                                                   01672000
   POINTER PXGLOBPNTR;                                                  01674000
   EQUATE PXGWJIT = 6;                                                  01676000
   INTEGER ARRAY TEMP (0:25);                                           01678000
   BYTE ARRAY BTEMP (*) = TEMP;                                         01680000
   DOUBLE ARRAY DTEMP (*) = TEMP;                                       01682000
<< >>                                                                   01684000
   ERRORON;                                                             01686000
   CHEK (WHOHANG, 8, %137752D, , %377);                                 01688000
<< BEGINNING ADDRESSES IN BOUNDS; NOW CHECK ENDING ADDRESSES >>         01690000
   CAPAD := CAPAD +1;                                                   01692000
   LATAD := LATAD +1;                                                   01694000
   XREG := 3;                                                           01696000
   DO BEGIN                                                             01698000
      BPARMS (XREG) := BPARMS (XREG) +7;                                01700000
      XREG := XREG -1;                                                  01702000
      END                                                               01704000
   UNTIL <;                                                             01706000
   CHEK (WHOHANG, 8, %37750D, , %377);                                  01708000
<< DOUBLE AND BYTE ADDRESSES ARE LEFT AT END OF PARAMETERS >>           01710000
   PUSH (DL);                                                           01712000
   @PXGLOBPNTR := TOS -INTEGER (SPNTR0 (-1)).(4:12);                    01714000
   TOS := PARMCNT;                                                      01716000
<< GET PCBX STUFF >>                                                    01718000
   IF LS0 THEN                                                          01720000
      TERMNUM := PXGLOBPNTR (PXGWJOBIN) LAND %377;                      01722000
   IF LS0 & LSR (7) THEN                                                01724000
      MODE := PXGLOBPNTR (PXGWFLAGS).(PXGFFLAGS);                       01726000
<< GET JIT STUFF, IF NECESSARY >>                                       01728000
   TOS := TOS LAND %176;                                                01730000
   IF > THEN                                                            01732000
      BEGIN                                                             01734000
      PUSH (DL);                                                        01736000
      TOS := -TOS +@TEMP;                                               01738000
      TOS := 16;                                                        01740000
      TOS := 26;                                                        01742000
      EXCHANGEDB (PXGLOBPNTR(PXGWJIT).(6:10));                          01744000
      ASSEMBLE (MVBL);                                                  01746000
      EXCHANGEDB (0);                                                   01748000
      IF LS0 & LSR(6) THEN                                              01750000
         BEGIN                                                          01752000
         CAPAD := CAPAD -1;                                             01754000
         CAPABILITY := DTEMP (11);                                      01756000
         END;                                                           01758000
      IF LS0 & LSR(5) THEN                                              01760000
         BEGIN                                                          01762000
         LATAD := LATAD -1;                                             01764000
         LATTR := DTEMP (9);                                            01766000
         END;                                                           01768000
      IF LS0 & LSR(4) THEN                                              01770000
         MOVE USERN := BTEMP(31),(-8);                                  01772000
      IF LS0 & LSR(3) THEN                                              01774000
         MOVE GROUPN := BTEMP(23), (-8);                                01776000
      IF LS0 & LSR(2) THEN                                              01778000
         MOVE ACCTN := BTEMP(7), (-8);                                  01780000
      IF LS0 & LSR(1) THEN                                              01782000
         MOVE HOMEN := BTEMP (15), (-8);                                01784000
      END;                                                              01786000
   ERROREXIT (WHOHANG, 0, 0);                                           01788000
   END    <<WHO>>;                                                      01790000
                                                                        01792000
                                                                        01794000
INTEGER PROCEDURE MYCOMMAND                                             01796000
   (COMIMAGE, DELIMITERS, MAXPARMS, NUMPARMS, PARMS, DICT, DEFN);       01798000
      VALUE MAXPARMS;                                                   01800000
<< FUNCTION:                                                            01802000
   EXTRACT AND FORMAT THE PARAMETERS OF <COMIMAGE>, AND (OPTIONALLY)    01804000
   EXTRACT A "COMMAND" AND SEARCH <DICT>. >>                            01806000
<< INPUT PARAMETERS: >>                                                 01808000
   BYTE ARRAY COMIMAGE;      <<(COMMAND AND) PARAMETERS IN AMOS FORMAT>>01810000
   BYTE ARRAY DELIMITERS;    <<(OPT.) ARRAY OF ADMISSABLE DELIMITERS>>  01812000
   INTEGER MAXPARMS;         <<SIZE OF PARMS IN DOUBLE-WORDS>>          01814000
   BYTE ARRAY DICT;          <<(OPTIONAL) EXTRACT COMMAND AND SEARCH >> 01816000
<< OUTPUT PARAMETERS: >>                                                01818000
   INTEGER NUMPARMS;          << NUMBER OF PARAMETERS IN COMIMAGE >>    01820000
   DOUBLE ARRAY PARMS;       <<PARAMETER DESCRIPTORS.  EACH DOUBLE:     01822000
      WORD 1: BYTE POINTER TO FIRST CHARACTER.                          01824000
      WORD 2: (11:5) = 0  FOLLOWED BY COMMA.                            01826000
                     = 1  FOLLOWED BY EQUAL.                            01828000
                     = 2  FOLLOWED BY SEMI-COLON.                       01830000
                     = 3  LAST PARAMETER.                               01832000
                     OR, IF <DELIMITERS> SPECIFIED, THEN BYTE DISP.     01834000
              (8:1)  = 1  CONTAINS ALPHABETICS.                         01836000
              (9:1)  = 1  CONTAINS NUMERICS.                            01838000
              (10:1) = 1  CONTAINS SPECIALS.                            01840000
              (0:8)  = LENGTH IN BYTES (0 IF OMITTED) >>                01842000
   BYTE POINTER DEFN;        <<   (SEE SEARCH INTRINSIC)  >>            01844000
   OPTION VARIABLE;                                                     01846000
<< RETURNS:                                                             01848000
   CCE- PARAMETERS FORMATTED. DICT NOT SUPPLIED, OR MYCOMMAND RETURNS   01850000
        COMMAND NUMBER (SEE SEARCH INTRINSIC).                          01852000
   CCG- TOO MANY PARAMETERS. <PARMS> FILLED WITH 1ST <MAXPARMS> OF THEM.01854000
   CCL- <DICT> SUPPLIED BUT COMMAND NOT FOUND. NO FORMATTING. >>        01856000
OPTION PRIVILEGED;                                                      01858000
BEGIN                                                                   01860000
   INTEGER S0 = S-0;                                                    01862000
   LOGICAL MYCOMMANDHANG := [10/71, 6/8];                               01864000
   LOGICAL PARMCOUNT = Q-4;                                             01866000
   BYTE POINTER PNTR = COMIMAGE;                                        01868000
   LOGICAL LMAXPARMS = MAXPARMS;                                        01870000
   LOGICAL START, ENDX;                                                 01872000
   BYTE POINTER COMMAND = START;                                        01874000
   INTEGER LENGTH = ENDX;                                               01876000
   LOGICAL CRBLANK _ %6440;                                             01878000
   LOGICAL                                                              01880000
      X1 := ",=",                                                       01882000
      X2 := %35415;                                                     01884000
   LOGICAL LASTFLAG := FALSE;                                           01886000
   DOUBLE LIMS;                                                         01888000
<< CODE >>                                                              01890000
   ERRORON;                                                             01892000
   TOS := (LIMS := CHEK (MYCOMMANDHANG, %107, %27217D, , %43));         01894000
   IF LMAXPARMS > 0 THEN                                                01896000
      BEGIN                                                             01898000
      IF LMAXPARMS > %20000 THEN ERROREXIT (MYCOMMANDHANG, 8, 3);       01900000
      XREG := @PARMS + (MAXPARMS & ASL(1)) - 1;                         01902000
      IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (MYCOMMANDHANG, 6, 5); 01904000
      END;                                                              01906000
   IF PARMCOUNT.(14:1) THEN                                             01908000
      BEGIN                                 <<EXTRACT COMMAND>>         01910000
      TOS := @PNTR;                                                     01912000
      ASSEMBLE (DUP, DUP);                                              01914000
      @COMMAND_ TOS;                                                    01916000
      MOVE * := * WHILE ANS, 0;                                <<04697>>01918000
      @PNTR_ TOS;                                                       01920000
      LENGTH_ TOS-@COMMAND;                                             01922000
      IF NOT(PARMCOUNT) THEN TOS := SEARCH (COMMAND, LENGTH, DICT)      01924000
      ELSE TOS_ SEARCH (COMMAND, LENGTH, DICT,  DEFN);                  01926000
      IF (MYCOMMAND _ TOS) = 0 THEN                                     01928000
         BEGIN                                                          01930000
         CC_ CCL;                                                       01932000
         ERROREXIT (MYCOMMANDHANG, 0, 0);                               01934000
         END;                                                           01936000
      IF CARRY THEN ERROREXIT (MYCOMMANDHANG, 21, 0);                   01938000
      END                                                               01940000
   ELSE MYCOMMAND _ 0;                                                  01942000
   IF NOT(PARMCOUNT.(10:1)) THEN @DELIMITERS := @X1 & LSL(1);           01944000
<< FORMAT PARAMETERS >>                                                 01946000
   XREG := 0;                                                           01948000
NEXTPARM:                                                               01950000
   SCAN PNTR WHILE CRBLANK, 1;                                          01952000
   ASSEMBLE (DUP, DUP);                                                 01954000
   @PNTR_ TOS;                                                          01956000
   START_ TOS;                                                          01958000
   TOS _ 0;                                                             01960000
   GOTO SCANALPHNUM;                                                    01962000
DOBLANK:                                                                01964000
   SCAN PNTR WHILE CRBLANK, 1;                                          01966000
   @PNTR_ TOS;                                                          01968000
   IF < THEN GOTO CHECKFUNNY;                                           01970000
DOSPECIAL:                                                              01972000
   TOS := TOS LOR %40;                                                  01974000
SCANALPHNUM:                                                            01976000
   TOS_ PNTR;                                                           01978000
   ASSEMBLE (DEL);                                                      01980000
   IF = THEN                                                            01982000
      BEGIN    <<ALPHABETIC>>                                           01984000
ALPH: TOS := TOS LOR %200;                                              01986000
      TOS_ @PNTR;                                                       01988000
      ASSEMBLE (DUP);                                                   01990000
      MOVE * := * WHILE AS, 1;                                          01992000
      @PNTR_ TOS;                                                       01994000
      END;                                                              01996000
   IF > THEN                                                            01998000
      BEGIN    <<NUMERIC>>                                              02000000
      TOS := TOS LOR %100;                                              02002000
      TOS_ @PNTR;                                                       02004000
      ASSEMBLE (DUP);                                                   02006000
      MOVE *_ * WHILE N, 1;                                             02008000
      @PNTR_ TOS;                                                       02010000
      END;                                                              02012000
   IF = THEN GOTO ALPH;                                                 02014000
   ENDX_ @PNTR;                                                         02016000
<< POSSIBILITIES NOW:                                                   02018000
   1. A DELIMETER,                                                      02020000
   2. A BLANKS-FIELD WITHIN PARAMETER,                                  02022000
   3. A BLANKS-FIELD JUST BEFORE DELIMETER, OR                          02024000
   4. A SPECIAL CHARACTER THAT'S PART OF PARAMETER. >>                  02026000
CHECKFUNNY:                                                             02028000
   SCAN DELIMITERS UNTIL (%6400 LOR LOGICAL(PNTR)), 1;                  02030000
   IF CARRY THEN                                                        02032000
      << 1. CHARACTER IS CR,                                            02034000
         2. CHARACTER IS SPECIAL OR BLANK.  >>                          02036000
      BEGIN                                                             02038000
      TOS := PNTR;                                                      02040000
      IF S0 <> %15 THEN                                                 02042000
         BEGIN                                                          02044000
         ASSEMBLE (DELB);                                               02046000
         @PNTR := @PNTR+1;                                              02048000
         IF TOS = " " THEN GOTO DOBLANK;                                02050000
         GOTO DOSPECIAL;                                                02052000
         END;                                                           02054000
      LASTFLAG := TOS;                                                  02056000
      TOS := XREG;                                                      02058000
      TOS := LIMS;                                                      02060000
      TOS := @PNTR & LSR(1);                                            02062000
      ASSEMBLE (DDUP, CMP);                                             02064000
      IF < THEN TOS.(0:1) := 1;                                         02066000
      XREG := TOS;                                                      02068000
      IF NOT (TOS <= XREG <= TOS) THEN ERROREXIT (MYCOMMANDHANG, 6, 1); 02070000
      XREG := TOS;                                                      02072000
      END;                                                              02074000
<< A DELIMITER FOUND >>                                                 02076000
   TOS := TOS-@DELIMITERS;    <<DELIMITER POSITION IN <DELIMITERS>.>>   02078000
   IF LOGICAL (S0) > 31 THEN ERROREXIT (MYCOMMANDHANG, 6, 2);           02080000
   TOS := ENDX-START;    <<PARAMETER LENGTH>>                           02082000
   <<SPECIAL CASE: NO PARAMETERS IN IMAGE>>                             02084000
      IF = AND LASTFLAG AND XREG = 0 THEN GOTO EXITOK;                  02086000
   IF LOGICAL (S0) > 255 THEN ERROREXIT (MYCOMMANDHANG, 20, 1);         02088000
   TOS := TOS LOR (TOS LOR (TOS & LSL(8)));                             02090000
   IF XREG >= MAXPARMS THEN                                             02092000
      BEGIN                                                             02094000
      CC := CCG;                                                        02096000
      GOTO EXIT;                                                        02098000
      END;                                                              02100000
   PARMS (XREG) := TOS;                                                 02102000
   XREG := XREG+1;                                                      02104000
   @PNTR := @PNTR+1;                                                    02106000
   IF NOT(LASTFLAG) THEN GOTO NEXTPARM;                                 02108000
EXITOK: CC := CCE;                                                      02110000
EXIT:   IF PARMCOUNT.(12:1) THEN NUMPARMS := XREG;                      02112000
   ERROREXIT (MYCOMMANDHANG, 0, 0);                                     02114000
END  <<MYCOMMAND>>;                                                     02116000
$PAGE                                                                   02118000
INTEGER PROCEDURE PRINTOPREPLY(MESSAGE,LENGTH,CONTROL,REPLY,            02120000
    REPLYLENGTH);                                                       02122000
VALUE LENGTH,CONTROL,REPLYLENGTH;                                       02124000
INTEGER                                                                 02126000
  LENGTH,      <<CONSOLE MESSAGE LENGTH-NEGATIVE FOR BYTES>>            02128000
  CONTROL,     <<OVERRIDE FOR STANDARD CONTROL-0=STANDARD CONTROL>>     02130000
  REPLYLENGTH; <<MAX ALLOWED REPLY LENGTH-NEGATIVE FOR BYTES>>          02132000
ARRAY                                                                   02134000
  MESSAGE,     <<TEXT TO BE OUTPUT TO CONSOLE>>                         02136000
  REPLY  ;     <<BUFFER FOR REPLY>>                                     02138000
OPTION PRIVILEGED;                                                      02140000
BEGIN                                                                   02142000
  LOGICAL PRINTOPRHANG:=[10/67,6/5]; <<INTRINSIC NUMBER=67>>            02144000
  LOGICAL POINTER TREPLY;                                               02146000
   ARRAY TEMP(0:25); BYTE ARRAY BTEMP(*)=TEMP;                 <<KS.02>>02148000
LOGICAL OUTVAL=PRINTOPREPLY;                                            02150000
  INTEGER S0=S-0;                                                       02152000
   INTEGER MAXCHARS;                                           <<06.EB>>02154000
  EQUATE CATNO=210;    <<MESSAGE NUMBER>>                               02156000
  IF REPLYLENGTH=0 THEN                                                 02158000
   BEGIN                                                                02160000
     IF LENGTH=0 THEN                                                   02162000
      BEGIN                                                             02164000
        CC:=CCL;                                                        02166000
        PRINTOPREPLY:=0;                                                02168000
        RETURN                                                          02170000
       END                                                              02172000
    ELSE BEGIN                                                          02174000
      PRINTOP(MESSAGE,LENGTH,CONTROL);                                  02176000
      IF= THEN CC:=CCE ELSE CC:=CCL;                                    02178000
      PRINTOPREPLY:=0;                                                  02180000
      RETURN;                                                           02182000
     END;                                                               02184000
    END;                                                                02186000
  ERRORON;                                                              02188000
<< CHECK PARAMETERS,BOUNDS>>                                            02190000
  TOS:=CHEK(PRINTOPRHANG,3,2D);                                         02192000
  ASSEMBLE(DDUP);                                                       02194000
  XREG:=@MESSAGE+(IF LENGTH <0 THEN(-LENGTH+1)&ASR(1)ELSE LENGTH)-1;    02196000
  IF NOT(TOS<=XREG<=TOS) THEN ERROREXIT(PRINTOPRHANG,6,1);              02198000
  XREG:=@REPLY+(IF REPLYLENGTH <0 THEN(-REPLYLENGTH+1)& ASR(1)          02200000
                                     ELSE REPLYLENGTH)-1;               02202000
  IF NOT(TOS<=XREG<=TOS) THEN  ERROREXIT(PRINTOPRHANG,6,4);             02204000
   MAXCHARS := IF REPLYLENGTH < 0 THEN -REPLYLENGTH            <<06.EB>>02206000
      ELSE REPLYLENGTH*2; << CONVERT TO BYTE COUNT >>          <<06.EB>>02208000
   IF MAXCHARS > 31 THEN MAXCHARS := 31;                       <<01458>>02210000
  IF LENGTH < 0 THEN                                           <<01458>>02212000
     BEGIN                                                     <<01458>>02214000
     IF LENGTH < -50 THEN LENGTH := -50;                       <<01458>>02216000
     END                                                       <<01458>>02218000
  ELSE                                                         <<01458>>02220000
     IF LENGTH > 25 THEN LENGTH := 25;                         <<01458>>02222000
   TOS:=@BTEMP;                                                <<KS.02>>02224000
   TOS:=@MESSAGE&LSL(1);                                       <<KS.02>>02226000
  TOS:=LENGTH;                                                          02228000
  IF < THEN TOS:=-TOS ELSE TOS:=TOS&ASL(1); <<BYTE COUNT>>              02230000
   CLEAN'MESSAGE(MESSAGE,S0);                                           02232000
   ASSEMBLE(MVB ,2); <<MOVE MESSAGE INTO TEMPORARY ARRAY>>     <<KS.02>>02234000
   BPS0:=0;         <<GENMSG NEEDS ZERO BYTE TERMINATOR>>      <<KS.02>>02236000
   DEL;                                                        <<KS.02>>02238000
  TOS:=REPLYLENGTH;                                                     02240000
  IF < THEN TOS:=(-TOS+1)&ASR(1); <<WORD COUNT>>                        02242000
  TOS:=TOS+1;<<1 MORE WD FOR RETURNED LENGTH>>                          02244000
  DUPLICATE;                                                            02246000
  ASSEMBLE(LRA S-0);                                                    02248000
  @TREPLY:=TOS;                                                         02250000
  ASSEMBLE (ADDS 0);                                                    02252000
   GENMSG(1,210,%1000,@BTEMP,MAXCHARS,,,,                      <<KS.02>>02254000
     0,MAXCHARS&LSL(8)+4,@TREPLY); << REPLEN=MAXCHARS,TYPE=4>> <<01458>>02256000
  IF <> THEN                                                   <<0U.EB>>02258000
    BEGIN                                                               02260000
      PRINTOPREPLY:=0;                                                  02262000
      CC:=CCL;                                                          02264000
      ERROREXIT(PRINTOPRHANG,0,0);                                      02266000
    END                                                                 02268000
    ELSE CC:=CCE;                                                       02270000
  TOS:=@REPLY&LSL(1);                                          <<00.06>>02272000
  TOS:=(@TREPLY+1)&LSL(1);                                     <<00.06>>02274000
  OUTVAL := MAXCHARS;                                          <<01458>>02276000
   IF OUTVAL>TREPLY THEN OUTVAL:=TREPLY;                                02278000
   MOVE *:=*,(OUTVAL);                                                  02280000
   IF REPLYLENGTH>0 THEN OUTVAL:=(OUTVAL+1)&ASR(1);                     02282000
                                                                        02284000
  ERROREXIT(PRINTOPRHANG,0,0);                                          02286000
END; <<PRINTOPREPLY>>                                                   02288000
$PAGE                                                                   02290000
$CONTROL SEGMENT= UTILITY2                                              02292000
PROCEDURE CTRANSLATE(CODE,INSTRING,OUTSTRING,STRINGLENGTH,              02294000
   TABLE);                                                              02296000
VALUE CODE,STRINGLENGTH;                                                02298000
INTEGER CODE,STRINGLENGTH;                                              02300000
BYTE ARRAY INSTRING,OUTSTRING,TABLE;                                    02302000
OPTION PRIVILEGED,VARIABLE;                                             02304000
BEGIN                                                                   02306000
     LOGICAL PMAP = Q-4;                                                02308000
     LOGICAL CTRANSHANG :=[10/61,6/6];                         <<WH.17>>02310000
     LOGICAL SPLITSTACK:=FALSE;                                         02312000
     INTEGER X =X;                                                      02314000
     INTEGER BERRTYPE;     <<BOUNDS VIOLATION TYPE>>                    02316000
     EQUATE                                                    <<01736>>02318000
          CODEMAX = 6;                                         <<01736>>02320000
     DOUBLE                                                    <<01736>>02322000
          BOUNDS;       << RETURN FROM CHEK. >>                <<01736>>02324000
     INTEGER                                                   <<01736>>02326000
          LOWERBOUND = BOUNDS,                                 <<01736>>02328000
          UPPERBOUND = BOUNDS + 1;                             <<01736>>02330000
     BYTE POINTER STRING;                                               02332000
     ARRAY ASCII'(0:255)=PB:=                                           02334000
          << EBCDIC TO ASCII CONVERSION TABLE >>                        02336000
          %000, %001, %002, %003, %234, %011, %206, %177,      <<01.02>>02338000
          %227, %215, %216, %013, %014, %015, %016, %017,      <<01.02>>02340000
          %020, %021, %022, %023, %235, %205, %010, %207,      <<01.02>>02342000
          %030, %031, %222, %217, %034, %035, %036, %037,      <<01.02>>02344000
          %200, %201, %202, %203, %204, %012, %027, %033,      <<01.02>>02346000
          %210, %211, %212, %213, %214, %005, %006, %007,      <<01.02>>02348000
          %220, %221, %026, %223, %224, %225, %226, %004,      <<01.02>>02350000
          %230, %231, %232, %233, %024, %025, %236, %032,      <<01.02>>02352000
          %040, %240, %241, %242, %243, %244, %245, %246,      <<01.02>>02354000
          %247, %250, %133, %056, %074, %050, %053, %041,      <<01.02>>02356000
          %046, %251, %252, %253, %254, %255, %256, %257,      <<01.02>>02358000
          %260, %261, %135, %044, %052, %051, %073, %136,      <<01.02>>02360000
          %055, %057, %262, %263, %264, %265, %266, %267,      <<01.02>>02362000
          %270, %271, %174, %054, %045, %137, %076, %077,      <<01.02>>02364000
          %272, %273, %274, %275, %276, %277, %300, %301,      <<01.02>>02366000
          %302, %140, %072, %043, %100, %047, %075, %042,      <<01.02>>02368000
          %303, %141, %142, %143, %144, %145, %146, %147,      <<01.02>>02370000
          %150, %151, %304, %305, %306, %307, %310, %311,      <<01.02>>02372000
          %312, %152, %153, %154, %155, %156, %157, %160,      <<01.02>>02374000
          %161, %162, %313, %314, %315, %316, %317, %320,      <<01.02>>02376000
          %321, %176, %163, %164, %165, %166, %167, %170,      <<01.02>>02378000
          %171, %172, %322, %323, %324, %325, %326, %327,      <<01.02>>02380000
          %330, %331, %332, %333, %334, %335, %336, %337,      <<01.02>>02382000
          %340, %341, %342, %343, %344, %345, %346, %347,      <<01.02>>02384000
          %173, %101, %102, %103, %104, %105, %106, %107,      <<01.02>>02386000
          %110, %111, %350, %351, %352, %353, %354, %355,      <<01.02>>02388000
          %175, %112, %113, %114, %115, %116, %117, %120,      <<01.02>>02390000
          %121, %122, %356, %357, %360, %361, %362, %363,      <<01.02>>02392000
          %134, %237, %123, %124, %125, %126, %127, %130,      <<01.02>>02394000
          %131, %132, %364, %365, %366, %367, %370, %371,      <<01.02>>02396000
          %060, %061, %062, %063, %064, %065, %066, %067,      <<01.02>>02398000
          %070, %071, %372, %373, %374, %375, %376, %377;      <<01.02>>02400000
     ARRAY EBCDIC'(0:255)=PB:=                                          02402000
          << ASCII TO EBCDIC CONVERSION TABLE >>                        02404000
          %000, %001, %002, %003, %067, %055, %056, %057,      <<01.02>>02406000
          %026, %005, %045, %013, %014, %015, %016, %017,      <<01.02>>02408000
          %020, %021, %022, %023, %074, %075, %062, %046,      <<01.02>>02410000
          %030, %031, %077, %047, %034, %035, %036, %037,      <<01.02>>02412000
          %100, %117, %177, %173, %133, %154, %120, %175,      <<01.02>>02414000
          %115, %135, %134, %116, %153, %140, %113, %141,      <<01.02>>02416000
          %360, %361, %362, %363, %364, %365, %366, %367,      <<01.02>>02418000
          %370, %371, %172, %136, %114, %176, %156, %157,      <<01.02>>02420000
          %174, %301, %302, %303, %304, %305, %306, %307,      <<01.02>>02422000
          %310, %311, %321, %322, %323, %324, %325, %326,      <<01.02>>02424000
          %327, %330, %331, %342, %343, %344, %345, %346,      <<01.02>>02426000
          %347, %350, %351, %112, %340, %132, %137, %155,      <<01.02>>02428000
          %171, %201, %202, %203, %204, %205, %206, %207,      <<01.02>>02430000
          %210, %211, %221, %222, %223, %224, %225, %226,      <<01.02>>02432000
          %227, %230, %231, %242, %243, %244, %245, %246,      <<01.02>>02434000
          %247, %250, %251, %300, %152, %320, %241, %007,      <<01.02>>02436000
          %040, %041, %042, %043, %044, %025, %006, %027,      <<01.02>>02438000
          %050, %051, %052, %053, %054, %011, %012, %033,      <<01.02>>02440000
          %060, %061, %032, %063, %064, %065, %066, %010,      <<01.02>>02442000
          %070, %071, %072, %073, %004, %024, %076, %341,      <<01.02>>02444000
          %101, %102, %103, %104, %105, %106, %107, %110,      <<01.02>>02446000
          %111, %121, %122, %123, %124, %125, %126, %127,      <<01.02>>02448000
          %130, %131, %142, %143, %144, %145, %146, %147,      <<01.02>>02450000
          %150, %151, %160, %161, %162, %163, %164, %165,      <<01.02>>02452000
          %166, %167, %170, %200, %212, %213, %214, %215,      <<01.02>>02454000
          %216, %217, %220, %232, %233, %234, %235, %236,      <<01.02>>02456000
          %237, %240, %252, %253, %254, %255, %256, %257,      <<01.02>>02458000
          %260, %261, %262, %263, %264, %265, %266, %267,      <<01.02>>02460000
          %270, %271, %272, %273, %274, %275, %276, %277,      <<01.02>>02462000
          %312, %313, %314, %315, %316, %317, %332, %333,      <<01.02>>02464000
          %334, %335, %336, %337, %352, %353, %354, %355,      <<01.02>>02466000
          %356, %357, %372, %373, %374, %375, %376, %377;      <<01.02>>02468000
     ARRAY JIS'(0:255)=PB:=                                    <<01.02>>02470000
          << EBCDIK TO JIS CONVERSION TABLE >>                 <<01.02>>02472000
          %000, %001, %002, %003, %234, %011, %206, %177,      <<01.02>>02474000
          %227, %215, %216, %013, %014, %015, %016, %017,      <<01.02>>02476000
          %020, %021, %022, %023, %235, %205, %010, %207,      <<01.02>>02478000
          %030, %031, %222, %217, %034, %035, %036, %037,      <<01.02>>02480000
          %200, %201, %202, %203, %204, %012, %027, %033,      <<01.02>>02482000
          %210, %211, %212, %213, %214, %005, %006, %007,      <<01.02>>02484000
          %220, %221, %026, %223, %224, %225, %226, %004,      <<01.02>>02486000
          %230, %231, %232, %233, %024, %025, %236, %032,      <<01.02>>02488000
          %040, %241, %242, %243, %244, %245, %246, %247,      <<00908>>02490000
          %250, %251, %133, %056, %074, %050, %053, %041,      <<00908>>02492000
          %046, %252, %253, %254, %255, %256, %257, %240,      <<00908>>02494000
          %260, %141, %135, %044, %052, %051, %073, %136,      <<01.02>>02496000
          %055, %057, %142, %143, %144, %145, %146, %147,      <<01.02>>02498000
          %150, %151, %174, %054, %045, %137, %076, %077,      <<01.02>>02500000
          %156, %160, %161, %162, %165, %164, %152, %153,      <<01.02>>02502000
          %154, %140, %072, %043, %100, %047, %075, %042,      <<01.02>>02504000
          %155, %261, %262, %263, %264, %265, %266, %267,      <<01.02>>02506000
          %270, %271, %272, %157, %273, %274, %275, %276,      <<01.02>>02508000
          %277, %300, %301, %302, %303, %304, %305, %306,      <<01.02>>02510000
          %307, %310, %311, %166, %163, %312, %313, %314,      <<01.02>>02512000
          %167, %176, %315, %316, %317, %320, %321, %322,      <<01.02>>02514000
          %323, %324, %325, %171, %326, %327, %330, %331,      <<01.02>>02516000
          %172, %170, %342, %343, %344, %345, %346, %347,      <<01.02>>02518000
          %340, %341, %332, %333, %334, %335, %336, %337,      <<01.02>>02520000
          %173, %101, %102, %103, %104, %105, %106, %107,      <<01.02>>02522000
          %110, %111, %350, %351, %352, %353, %354, %355,      <<01.02>>02524000
          %175, %112, %113, %114, %115, %116, %117, %120,      <<01.02>>02526000
          %121, %122, %356, %357, %360, %361, %362, %363,      <<01.02>>02528000
          %134, %237, %123, %124, %125, %126, %127, %130,      <<01.02>>02530000
          %131, %132, %364, %365, %366, %367, %370, %371,      <<01.02>>02532000
          %060, %061, %062, %063, %064, %065, %066, %067,      <<01.02>>02534000
          %070, %071, %372, %373, %374, %375, %376, %377;      <<01.02>>02536000
     ARRAY EBCDIK'(0:255)=PB:=                                 <<01.02>>02538000
          << JIS TO EBCDIK CONVERSION TABLE >>                 <<01.02>>02540000
          %000, %001, %002, %003, %067, %055, %056, %057,      <<01.02>>02542000
          %026, %005, %045, %013, %014, %015, %016, %017,      <<01.02>>02544000
          %020, %021, %022, %023, %074, %075, %062, %046,      <<01.02>>02546000
          %030, %031, %077, %047, %034, %035, %036, %037,      <<01.02>>02548000
          %100, %117, %177, %173, %133, %154, %120, %175,      <<01.02>>02550000
          %115, %135, %134, %116, %153, %140, %113, %141,      <<01.02>>02552000
          %360, %361, %362, %363, %364, %365, %366, %367,      <<01.02>>02554000
          %370, %371, %172, %136, %114, %176, %156, %157,      <<01.02>>02556000
          %174, %301, %302, %303, %304, %305, %306, %307,      <<01.02>>02558000
          %310, %311, %321, %322, %323, %324, %325, %326,      <<01.02>>02560000
          %327, %330, %331, %342, %343, %344, %345, %346,      <<01.02>>02562000
          %347, %350, %351, %112, %340, %132, %137, %155,      <<01.02>>02564000
          %171, %131, %142, %143, %144, %145, %146, %147,      <<01.02>>02566000
          %150, %151, %166, %167, %170, %200, %160, %213,      <<01.02>>02568000
          %161, %162, %163, %234, %165, %164, %233, %240,      <<01.02>>02570000
          %261, %253, %260, %300, %152, %320, %241, %007,      <<01.02>>02572000
          %040, %041, %042, %043, %044, %025, %006, %027,      <<01.02>>02574000
          %050, %051, %052, %053, %054, %011, %012, %033,      <<01.02>>02576000
          %060, %061, %032, %063, %064, %065, %066, %010,      <<01.02>>02578000
          %070, %071, %072, %073, %004, %024, %076, %341,      <<01.02>>02580000
          %127, %101, %102, %103, %104, %105, %106, %107,      <<00908>>02582000
          %110, %111, %121, %122, %123, %124, %125, %126,      <<00908>>02584000
          %130, %201, %202, %203, %204, %205, %206, %207,      <<01.02>>02586000
          %210, %211, %212, %214, %215, %216, %217, %220,      <<01.02>>02588000
          %221, %222, %223, %224, %225, %226, %227, %230,      <<01.02>>02590000
          %231, %232, %235, %236, %237, %242, %243, %244,      <<01.02>>02592000
          %245, %246, %247, %250, %251, %252, %254, %255,      <<01.02>>02594000
          %256, %257, %272, %273, %274, %275, %276, %277,      <<01.02>>02596000
          %270, %271, %262, %263, %264, %265, %266, %267,      <<01.02>>02598000
          %312, %313, %314, %315, %316, %317, %332, %333,      <<01.02>>02600000
          %334, %335, %336, %337, %352, %353, %354, %355,      <<01.02>>02602000
          %356, %357, %372, %373, %374, %375, %376, %377;      <<01.02>>02604000
     LOGICAL SUBROUTINE BOUNDCHK(CSTRING,CSTRINGLENGTH);                02606000
     VALUE CSTRING,CSTRINGLENGTH;                                       02608000
     INTEGER CSTRING,CSTRINGLENGTH;                                     02610000
     BEGIN                                                              02612000
          XREG := CSTRING&LSR(1);                                       02614000
          IF NOT SPLITSTACK  THEN        << NORMAL STACK >>             02616000
             BEGIN                                                      02618000
                  PUSH(S);    << CHECK FOR DL-DB ADDRESSING >>          02620000
                  IF TOS < XREG  THEN XREG := XREG + %100000;           02622000
             END;                                                       02624000
          IF NOT (LOWERBOUND<=XREG<=UPPERBOUND) THEN                    02626000
             BEGIN                                                      02628000
                   BERRTYPE:=5;                                         02630000
                   RETURN;                                              02632000
             END;                                                       02634000
          IF CSTRINGLENGTH <> 0  THEN                                   02636000
            BEGIN                                                       02638000
                 XREG:=XREG+((CSTRINGLENGTH + 1)&LSR(1))-1;             02640000
                 IF NOT (LOWERBOUND<=XREG<=UPPERBOUND)  THEN            02642000
                    BEGIN                                               02644000
                         BERRTYPE := 6;                                 02646000
                         RETURN;                                        02648000
                    END;                                                02650000
            END;                                                        02652000
         BOUNDCHK:=TRUE;                                                02654000
     END <<BOUNDCHK>>;                                                  02656000
     ERRORON;                                                           02658000
     CC := CCL;                                                <<00.04>>02660000
                                                               <<01736>>02662000
  << FOR THIS RELEASE DISALLOW SPLIT STACK CALLS. >>           <<01736>>02664000
  << TO IMPLEMENT, CHANGE LINE AFTER "CHEK" CALL: >>           <<01736>>02666000
  <<                                              >>           <<01736>>02668000
  << IF CARRY THEN SPLITSTACK := TRUE;            >>           <<01736>>02670000
                                                               <<01736>>02672000
     BOUNDS := CHEK(CTRANSHANG,%5,,,%5);                       <<01736>>02674000
     IF CARRY THEN ERROREXIT(CTRANSHANG,1,0);                  <<01736>>02676000
                                                               <<01736>>02678000
     IF NOT (0<=CODE<=CODEMAX) THEN ERROREXIT(CTRANSHANG,8,1);          02680000
     IF STRINGLENGTH < 0 THEN ERROREXIT(CTRANSHANG,8,4);                02682000
     IF STRINGLENGTH = 0 THEN GOTO FIN;                        <<00.04>>02684000
                            << WE'RE DONE IF LENGTH=0 >>                02686000
                                                                        02688000
     IF NOT BOUNDCHK(@INSTRING,STRINGLENGTH)  THEN                      02690000
     ERROREXIT(CTRANSHANG,BERRTYPE,2);                                  02692000
     IF PMAP.(13:1) THEN  <<OUTPUT STRING SPEC.>>                       02694000
     BEGIN                                                              02696000
          IF NOT BOUNDCHK(@OUTSTRING,STRINGLENGTH)  THEN                02698000
          ERROREXIT(CTRANSHANG,BERRTYPE,3);                             02700000
          @STRING:=@OUTSTRING;                                          02702000
     END ELSE                                                           02704000
     @STRING:=@INSTRING;                                                02706000
     TOS:=0D;                                                           02708000
     CASE * CODE OF                                                     02710000
     BEGIN                                                              02712000
     BEGIN COMMENT  CODE=0, USER TABLE.  ;                     <<01.02>>02714000
               IF NOT PMAP THEN ERROREXIT(CTRANSHANG,3,5) ELSE          02716000
               IF NOT BOUNDCHK(@TABLE,0)  THEN                          02718000
               ERROREXIT(CTRANSHANG,BERRTYPE,5);                        02720000
               XREG:=0;     <<BYTE STRING INDEX>>                       02722000
               WHILE TOS < STRINGLENGTH DO                              02724000
               BEGIN                                                    02726000
                    TOS:=INSTRING(XREG);                                02728000
                    ASSEMBLE(LDXB,STAX);                                02730000
                    TOS:=TABLE(XREG);                                   02732000
                    ASSEMBLE(STBX,NOP);                                 02734000
                    STRING(XREG):=TOS;                                  02736000
                    ASSEMBLE(INCX,LDXA);                                02738000
               END;                                                     02740000
          END;                                                          02742000
     BEGIN COMMENT  CODE=1, EBCDIC TO ASCII.  ;                <<01.02>>02744000
               XREG:=0;     <<BYTE STRING INDEX>>                       02746000
               WHILE TOS < STRINGLENGTH DO                              02748000
               BEGIN                                                    02750000
                    TOS:=INSTRING(XREG);                                02752000
                    ASSEMBLE(LDXB,STAX);                                02754000
                    TOS:=ASCII'(XREG);                                  02756000
                    ASSEMBLE(STBX,NOP);                                 02758000
                    STRING(XREG):=TOS;                                  02760000
                    ASSEMBLE(INCX,LDXA);                                02762000
               END;                                                     02764000
          END;                                                          02766000
     BEGIN COMMENT  CODE=2, ASCII TO EBCDIC.  ;                <<01.02>>02768000
               XREG:=0;     <<BYTE STRING INDEX>>                       02770000
               WHILE TOS < STRINGLENGTH DO                              02772000
               BEGIN                                                    02774000
                    TOS:=INSTRING(XREG);                                02776000
                    ASSEMBLE(LDXB,STAX);                                02778000
                    TOS:=EBCDIC'(XREG);                                 02780000
                    ASSEMBLE(STBX,NOP);                                 02782000
                    STRING(XREG):=TOS;                                  02784000
                    ASSEMBLE(INCX,LDXA);                                02786000
               END;                                                     02788000
          END;                                                          02790000
     BEGIN COMMENT  CODE=3, NATIVE TO ASCII.  ;                <<01.02>>02792000
          CC := CCL;  ERROREXIT(CTRANSHANG,8,1);               <<01.02>>02794000
     END;                                                      <<01.02>>02796000
     BEGIN COMMENT  CODE=4,  ASCII TO NATIVE.  ;               <<01.02>>02798000
          CC := CCL;  ERROREXIT(CTRANSHANG,8,1);               <<01.02>>02800000
     END;                                                      <<01.02>>02802000
     BEGIN COMMENT  CODE=5,  EBCDIK TO JIS.  ;                 <<01.02>>02804000
          XREG:=0;     << BYTE STRING INDEX >>                 <<01.02>>02806000
          WHILE TOS < STRINGLENGTH DO                          <<01.02>>02808000
          BEGIN                                                <<01.02>>02810000
               TOS:=INSTRING(XREG);                            <<01.02>>02812000
               ASSEMBLE(LDXB,STAX);                            <<01.02>>02814000
               TOS:=JIS'(XREG);                                <<01.02>>02816000
               ASSEMBLE(STBX,NOP);                             <<01.02>>02818000
               STRING(XREG):=TOS;                              <<01.02>>02820000
               ASSEMBLE(INCX,LDXA);                            <<01.02>>02822000
          END;                                                 <<01.02>>02824000
     END;                                                      <<01.02>>02826000
     BEGIN COMMENT  CODE=6,  JIS TO EBCDIK.  ;                 <<01.02>>02828000
          XREG:=0;     << BYTE STRING INDEX >>                 <<01.02>>02830000
          WHILE TOS < STRINGLENGTH DO                          <<01.02>>02832000
          BEGIN                                                <<01.02>>02834000
               TOS:=INSTRING(XREG);                            <<01.02>>02836000
               ASSEMBLE(LDXB,STAX);                            <<01.02>>02838000
               TOS:=EBCDIK'(XREG);                             <<01.02>>02840000
               ASSEMBLE(STBX,NOP);                             <<01.02>>02842000
               STRING(XREG):=TOS;                              <<01.02>>02844000
               ASSEMBLE(INCX,LDXA);                            <<01.02>>02846000
          END;                                                 <<01.02>>02848000
     END;                                                      <<01.02>>02850000
     END <<CASE>>;                                                      02852000
FIN:                                                           <<00.04>>02854000
     CC := CCE;                                                <<00.04>>02856000
     ERROREXIT(CTRANSHANG,0,0);                                         02858000
END <<CTRANSLATE>>;                                                     02860000
$PAGE "FCARD - 7260A CARD READER INTRINSIC "<<00.05-LINES 1165.004->>   02862000
PROCEDURE FCARD(RECODE,FILENUM,BUFADR,COUNT,STATUS);<<LINES 1165.223>>  02864000
INTEGER ARRAY BUFADR;                                                   02866000
INTEGER RECODE,FILENUM,COUNT,STATUS;                                    02868000
                                                                        02870000
BEGIN                                                                   02872000
                                                                        02874000
COMMENT                                                                 02876000
   ASSUMING THAT THE USER OF THE CARD READER HAS SATISFACTORILY         02878000
   INSTALLED THE CARD READER, THIS PROCEDURE WILL PERFORM THE ACTUAL    02880000
   ISSUEING OF REQUESTS AND RETURNING OF DATA/STATUS FOR THE USERS      02882000
   PROGRAM.                                                             02884000
                                                                        02886000
      DESCRIPTION OF INPUT PARAMETERS                                   02888000
      RECODE = O = OPEN THE CARD READER/TERMINAL PAIR AS A FILE         02890000
             = 1 = DEMAND A CARD                                        02892000
             = 2 = REJECT THE LAST CARD READ                            02894000
             = 3 = RETRANSMIT THE DATA                                  02896000
             = 4 = SUSPEND PROGRAM AWAITING THE "READY" SIGNAL          02898000
             =10 = CAUSE CARD READER TO GO "NOT READY" VIA STOP COMMAND 02900000
             =11 = SWITCH TO IMAGE                                      02902000
             =12 = SWITCH TO ASCII                                      02904000
             =13 = RING BELL                                            02906000
             =17 = TURN ECHO ON                                         02908000
             =18 = TURN ECHO OFF                                        02910000
             =20 = CLOSE FILE SPECIFIED IN FILENUM(RESULT OR RECODE=0)  02912000
                                                                        02914000
      FILENUM IS THE FILE NUMBER RETURNED FROM RECODE=0. IT MUST BE     02916000
             PROVIDED ON ALL REQUEST FOR CARD READER ACTION.            02918000
                                                                        02920000
      BUFADR IS THE ARRAY INTO WHICH CARD DATA WILL BE READ.            02922000
                                                                        02924000
      COUNT IS THE TRANSFER COUNT IN BYTES.                             02926000
                                                                        02928000
      STATUS = O = DATA IN BUFADR                                       02930000
             # O = ACTUAL STATUS AS RETURNED                            02932000
                                                                        02934000
      DESCRIPTION OF OUTPUT PARAMETERS                                  02936000
      RECODE = 0 = REQUEST GOT A RETURN FROM THE CARD READER            02938000
         THEN: 1 IF RECODE WAS 0 THEN FILE NUMBER IS RETURNED IN FILENUM02940000
               2 IF CARD READER REQUEST REQUIRED A RESPONSE             02942000
                  A BUFADR CONTAINS RESPONSE                            02944000
                  B COUNT IS NUMBER OF BYTES OR WORDS (IF IN IMAGE MODE)02946000
                  C FILENUM IS UNCHANGED                                02948000
                  D STATUS IS CONTROL CHAR IF BUFADR IS NOT DATA        02950000
               3 IF REQUEST DOES NOT REQUIRE A RESPONSE THEN NONE OF    02952000
                 THE  RETURN PARAMETERS ARE SIGNIFICANT                 02954000
               4 IF RECODE WAS 20 THE FILE SPECIFIED IN FILENUM IS      02956000
                 CLOSED.                                                02958000
      RECODE = 1 = ILLEGAL REQUEST CODE                                 02960000
             = 2 = UNABLE TO OPEN FILE                                  02962000
             = 4 = FREAD OR FWRITE ERROR                                02964000
             = 5 = UNABLE TO CLOSE FILE                                 02966000
             = 6 = :EOJ, :EOD, :DATA, OR :JOB FOUND IN INPUT            02968000
             = 7 = FILE ERROR ON EITHER ECHO ON OR ECHO OFF             02970000
             = 8 = DATA DROPOUT - USUAL RECOVERY IS TO RETRANSMIT       02972000
                                                                        02974000
                                                                        02976000
;                                                                       02978000
INTEGER BYTECOUNT;                                                      02980000
INTRINSIC FCHECK;                                                       02982000
INTEGER ECHO;                                                           02984000
INTEGER LDN,ERROR,Z,N,Z5:=%6415,Z6:=0;                                  02986000
  INTEGER I;                                                            02988000
BYTE ARRAY CONCHAR(0:7);                                                02990000
BYTE ARRAY LDEV(0:2);                                                   02992000
BYTE ARRAY CHAROUT(0:4);                                                02994000
BYTE ARRAY RPACK(*)=BUFADR;                                             02996000
INTEGER POINTER PTR;                                                    02998000
INTRINSIC FOPEN,FREAD,FWRITE,FCONTROL,FCLOSE,FGETINFO,ASCII,PRINT;      03000000
                                                                        03002000
SUBROUTINE REPACK;                                                      03004000
BEGIN                                                                   03006000
  FOR I:=0 UNTIL (COUNT-2) DO RPACK(I):=RPACK(I+1);                     03008000
  COUNT:=COUNT-1;                                                       03010000
  RETURN;                                                               03012000
END;                                                                    03014000
                                                                        03016000
SUBROUTINE IMAGE5;                                                      03018000
BEGIN                                                                   03020000
  FOR I:=0 UNTIL (COUNT/2)-1 DO BEGIN                                   03022000
    BUFADR(I).(4:6):=BUFADR(I+1).(10:6);                                03024000
    BUFADR(I).(10:6):=BUFADR(I+1).(2:6);                                03026000
    BUFADR(I).(0:4):=0;                                                 03028000
  END;                                                                  03030000
  COUNT:=(COUNT/2)-1;                                                   03032000
  RETURN;                                                               03034000
END;                                                                    03036000
                                                                        03038000
SUBROUTINE FILERROR;                                                    03040000
BEGIN                                                                   03042000
   FCHECK(FILENUM,ERROR);                                               03044000
   IF ERROR.(8:8)=33 THEN RECODE:=8                                     03046000
                     ELSE RECODE:=4;                                    03048000
  RETURN;                                                               03050000
END;                                                                    03052000
                                                                        03054000
                                                                        03056000
   IF (0<=RECODE<=4) OR (10<=RECODE<=13) OR (RECODE=20)                 03058000
                     OR (17<=RECODE<=18) THEN GO NOTILL;                03060000
   RECODE:=1; RETURN;      <<ILLEGAL REQUEST CODE>>                     03062000
                                                                        03064000
NOTILL: <<REQUEST CODE IS LEGAL VALUE>>                                 03066000
   <<BRANCH TO AREA NAMED BY RECODE>>                                   03068000
   IF RECODE = 0 THEN GO OPENFILE;                                      03070000
   IF (17<=RECODE<=18) THEN GO ECHOSWITCH;                              03072000
   IF RECODE = 20 THEN GO CLOSEFILE;                                    03074000
                                                                        03076000
   <<INITIALIZE CONTROL CHARACTER BUFFER>>                              03078000
   MOVE CONCHAR(0) :=(%31,%13,%10,%11,%11,%22,%24,%07);                 03080000
   CHAROUT(0):=%24; CHAROUT(1):=%24; CHAROUT(2):=%21;CHAROUT(4):=%21;   03082000
   <<CONVERT BYTE ADDRESS TO WORD ADDRESS>>                             03084000
   @PTR:=@CHAROUT & LSR(1);                                             03086000
   IF (10<=RECODE<=13) THEN CHAROUT(3):=CONCHAR(RECODE-6)               03088000
                       ELSE CHAROUT(3):=CONCHAR(RECODE-1);              03090000
   IF RECODE > 3 THEN BYTECOUNT:=-5 ELSE BYTECOUNT:=-4;                 03092000
                                                                        03094000
   <<SEND THE REQUEST TO THE CARD READER>>                              03096000
   FWRITE(FILENUM,PTR,BYTECOUNT,%320);                                  03098000
   <<CHECK FOR WRITE ERROR>>                                            03100000
   IF <> THEN GO ERROR4;                                                03102000
    IF RECODE = 4 THEN GO READYWAIT;                                    03104000
   IF RECODE > 3 THEN GO GOODEXIT;                                      03106000
                                                                        03108000
   <<REQUEST REQUIRES RETURN FROM READER SO GIVE A READ REQUEST>>       03110000
   FCONTROL(FILENUM,41,Z5);  <<SET UP TRANSPARENT MODE OF READ >>       03112000
   COUNT:=FREAD(FILENUM,BUFADR,-240);                                   03114000
   <<CHECK FOR READ ERROR>>                                             03116000
   IF > THEN                                                            03118000
     BEGIN                                                              03120000
       FCONTROL(FILENUM,41,Z6); GOTO ERROR6;  END;                      03122000
   IF < THEN BEGIN                                                      03124000
             FCONTROL(FILENUM,41,Z6); << DISABLE TRANSPARENT MODE >>    03126000
             FILERROR;                                                  03128000
             RETURN;                                                    03130000
             END;                                                       03132000
   FCONTROL(FILENUM,41,Z6); << DISABLE TRANSPARENT MODE AFTER READ >>   03134000
                                                                        03136000
   <<CHECK FOR STATUS IN 1ST BYTE OF BUFFER>>                           03138000
   STATUS:=BUFADR(0).(0:8);                                             03140000
   IF (STATUS=%14) OR (STATUS=%13) OR (STATUS=%22) OR                   03142000
       (STATUS=%07) OR (STATUS=%11) OR (STATUS=%37)                     03144000
       THEN GO GOODEXIT      <<CARD READER GAVE STATUS>>                03146000
     ELSE BEGIN STATUS:=0;IF BUFADR(0)="QH" THEN IMAGE5 ELSE            03148000
            IF RPACK(0)=(%12) THEN REPACK;                              03150000
          END;                                                          03152000
                                                                        03154000
GOODEXIT:                                                               03156000
   <<INDICATE SUCCESSFUL REQUEST>>                                      03158000
   RECODE:=0; RETURN;                                                   03160000
                                                                        03162000
READYWAIT:                                                              03164000
   <<SEND SET OF CHARS TO READER THAT WILL CAUSE IT NOT TO RESPOND>>    03166000
   CHAROUT(0):=%11;  <<CAUSES A STOP-STOP-EXECUTE TO BE WRITTEN TO CR>> 03168000
   FWRITE(FILENUM,PTR,BYTECOUNT,%320);                                  03170000
   IF <> THEN GO ERROR4;                                                03172000
   <<BECAUSE THE CR IS NOW IN A SLEEP STATE THE NEXT FREAD WILL BE>>    03174000
   <<IGNORED BUT THE SYSTEM WILL STILL BE AWAITING INPUT. PUSH READY>>  03176000
                                                                        03178000
READYLOOP:                                                              03180000
FCONTROL(FILENUM,29,PTR); <<ENABLE USER BLK MODE>>                      03182000
   COUNT:=FREAD(FILENUM,BUFADR,-240);                                   03184000
   IF > THEN GO ERROR6;                                                 03186000
   IF < THEN BEGIN                                                      03188000
             FILERROR;                                                  03190000
FCONTROL(FILENUM,28,PTR); <<DISABLE USER BLK MODE>>                     03192000
             IF RECODE = 4 THEN RETURN                                  03194000
                           ELSE GO READYLOOP;                           03196000
             END;                                                       03198000
   <<CHECK THAT 1ST BYTE IS READY CHARACTER>>                           03200000
   IF BUFADR(0).(0:8) <> %22 THEN GO READYLOOP     <<WAIT FOR READY>>   03202000
                             ELSE BEGIN                                 03204000
                                  STATUS:=BUFADR(0).(0:8);              03206000
                                  GO GOODEXIT;                          03208000
                                  END;                                  03210000
                                                                        03212000
OPENFILE: <<OPEN TERMINAL FOR INPUT AND OUTPUT>>                        03214000
   <<FIRST GET THE LOGICAL DEV # OF $STDLIST>>                          03216000
   FILENUM:=FOPEN(,%14);   <<OPEN $STDLIST>>                            03218000
   IF <> THEN GO ERROR2;                                                03220000
   FGETINFO(FILENUM,,,,,,LDN);   <<GET LOG DEV #>>                      03222000
   FCLOSE(FILENUM,0,0);    <<CLOSE $STDLIST>>                           03224000
   <<CONVERT LOGICAL DEV # TO ASCII STRING>>                            03226000
   Z:=100;                                                              03228000
   FOR N:=0 UNTIL 2 DO                                                  03230000
      BEGIN                                                             03232000
      LDEV(N):=LDN/Z + %60;                                             03234000
      LDN:=LDN MOD Z;  Z:=Z/10;                                         03236000
      END;                                                              03238000
   <<OPEN FILE VIA LOGICAL DEV # FOR INPUT AND OUTPUT>>                 03240000
   FILENUM:=FOPEN(,%2404,4,100,LDEV);                                   03242000
   IF <> THEN GO ERROR2;                                                03244000
   GO GOODEXIT;                                                         03246000
                                                                        03248000
CLOSEFILE:  <<CLOSE TERMINAL INPUT/OUTPUT FILE>>                        03250000
   FCLOSE(FILENUM,0,0);          <<CLOSE LOG DEV # FILE>>               03252000
   IF <> THEN GO ERROR5                                                 03254000
         ELSE GO GOODEXIT;                                              03256000
                                                                        03258000
ECHOSWITCH:  <<ALLOW THE USER CONTROL OF ECHO>>                         03260000
   <<RECODE = 17 = ECHO OFF - RECODE = 18 ECHO ON>>                     03262000
   IF RECODE = 17 THEN ECHO:=12     <<TURN ECHO ON>>                    03264000
                  ELSE ECHO:=13;    <<TURN ECHO OFF>>                   03266000
   FCONTROL(FILENUM,ECHO,Z);                                            03268000
   IF = THEN GO GOODEXIT;                                               03270000
   <<ECHO ON OR OFF ERROR>>                                             03272000
   RECODE := 7; RETURN;                                                 03274000
                                                                        03276000
ERROR2: <<UNABLE TO OPEN FILE >>                                        03278000
   RECODE:=2; RETURN;                                                   03280000
                                                                        03282000
ERROR4:  <<FWRITE ERROR>>                                               03284000
   RECODE:=4; RETURN;                                                   03286000
                                                                        03288000
ERROR5: <<UNABLE TO CLOSE FILE >>                                       03290000
   RECODE:=5; RETURN;                                                   03292000
                                                                        03294000
ERROR6: <<ENCOUNTERED :EOJ, :EOD, :DATA, OR :JOB IN INPUT STREAM>>      03296000
   RECODE:=6; RETURN;                                                   03298000
END;                                                                    03300000
$PAGE "PTAPE - PAPER TAPE SPOOLING PROCEDURE "                 <<00.05>>03302000
                                                               <<00.05>>03304000
PROCEDURE PTAPE(TFILE,DFILE);                                  <<00.05>>03306000
  VALUE TFILE, DFILE;                                          <<00.05>>03308000
  INTEGER TFILE, DFILE;                                        <<00.05>>03310000
  OPTION PRIVILEGED;                                           <<00.05>>03312000
  <<                                                       >>  <<00.05>>03314000
  <<READS PAPER TAPE FROM TFILE AND SPOOLS IT TO DFILE     >>  <<00.05>>03316000
  <<RETURN: CCE - SUCCESSFUL                               >>  <<00.05>>03318000
  <<        CCL - TFILE NOT A TERMINAL                     >>  <<00.05>>03320000
  <<        CCG - NO RESOURCES, SYSTEM ERROR OR TOO MUCH DA>>  <<00.05>>03322000
  <<                                                       >>  <<00.05>>03324000
  BEGIN                                                        <<00.05>>03326000
    DOUBLE DISKADR := 0D;                                      <<02852>>03328000
    INTEGER DISKADR0 = DISKADR,                                <<02852>>03330000
            DISKADR1 = DISKADR0 + 1;                           <<02852>>03332000
    INTEGER I, TEMP, DEVICETYPE, LDEV;                         <<00.05>>03334000
                                                               <<00.05>>03336000
    LOGICAL TOGGLE = LDEV+1;  << OVEN/EVEN BYTE FLAG/CNTR >>   <<00.05>>03338000
    INTEGER ITOGGLE = TOGGLE;  << FOR TOGGLING TOGGLE >>       <<00.05>>03340000
                                                               <<00.05>>03342000
    LOGICAL ESCFLAG = TOGGLE+1;  << LAST CHAR WAS ESC>>        <<00.05>>03344000
    LOGICAL DELFLAG = ESCFLAG+1;  << SET FOR LINE DELETE >>    <<00.05>>03346000
    INTEGER RETURNCC= DELFLAG+1;  << RETURN COND CODE  >>      <<00.05>>03348000
    INTEGER BCNT = RETURNCC+1;  << REC BUFFER BYTE INDEX >>    <<00.05>>03350000
                                                               <<00.05>>03352000
    INTEGER SAVECRITICAL = BCNT+1;                             <<00.05>>03354000
    INTEGER SBUFX = SAVECRITICAL+1;  <<  SBUF INDEX >>         <<00.05>>03356000
    INTEGER DSTX = SBUFX+1;    << DUMY DST INDEX >>            <<00.05>>03358000
                                                               <<00.05>>03360000
    DOUBLE DADDR = DSTX+1;    << SPOOL BUFFER DISC ADDR >>     <<00.05>>03362000
    INTEGER DADR0 = DADDR, DADR1 = DADDR+1;                    <<00.05>>03364000
                                                               <<00.05>>03366000
    BYTE ARRAY RBUF(*) = DADDR+2;    << RECORD BUFFER >>       <<00.05>>03368000
    INTEGER ARRAY IRBUF(*) = RBUF;                             <<00.05>>03370000
    INTEGER POINTER SYSBUF = 6;  << SYSTEM TABLE POINTER >>    <<00.05>>03372000
    INTEGER POINTER DSTP   = 2;   << SYSTEM TABLE POINTER >>   <<00.05>>03374000
                                                               <<00.05>>03376000
    EQUATE                                                     <<00.05>>03378000
    PTINUMB   =[8/191, 8/2],  << PTAPE INTRINSIC NUMBER >>     <<00.05>>03380000
    TSUBTYPE  = 16,        << TERMINAL DEVICE TYPE >>          <<00.05>>03382000
    PTAPEFUNC = 29,        << PTAPE SPOOLING FUNC >>           <<00.05>>03384000
    READFUNC  = 0,         << READ FUNC >>                     <<00.05>>03386000
    SYSDISK   = 1,         << SYSTEM DISC LOG DEV >>           <<00.05>>03388000
    GOODIO    = 1,         << GOOD I/O STATUS RETURN >>        <<00.05>>03390000
    CR        = %15,       << CARRIAGE RETURN CHAR >>          <<00.05>>03392000
    Y'C       = %31;       << CONTROL-Y CHAR >>                <<00.05>>03394000
                                                               <<00.05>>03396000
    DEFINE                                                     <<00.05>>03398000
    IOSTAT    = (8:8)#,                                        <<00.05>>03400000
    CHARMASK  = (8:8)#;                                        <<00.05>>03402000
                                                               <<00.05>>03404000
    ASSEMBLE(DZRO,DZRO);<< TOGGLE,ESCFLAG,DELFLAG,RETURNCC>>   <<00.05>>03406000
    ASSEMBLE(INCA,DZRO);<< RETURNCC := CCL, BCNT, SAVECRIT>>   <<00.05>>03408000
                                                               <<00.05>>03410000
    ASSEMBLE( PCAL SETCRITICAL );  << SET SAVECRITICAL >>      <<00.05>>03412000
    ERRORON;                                                   <<00.05>>03414000
    FGETINFO(TFILE,,,,,DEVICETYPE,LDEV);                       <<00.05>>03416000
    IF <> OR DEVICETYPE.(8:8)<>TSUBTYPE THEN                   <<00.05>>03418000
      GOTO OUT1;   << INVALID TFILE OR DEV NOT TERMINAL >>     <<00.05>>03420000
                                                               <<00.05>>03422000
    RETURNCC := CCG;                                           <<00.05>>03424000
    TOS := GETSYSBUF(2,TRUE);  << GET 2 SBUFS/SET SBUFX >>     <<00.05>>03426000
   TOS := Get'Disc'Space (sysdisk, 128D, diskadr);             <<03506>>03428000
    IF S0 <> 0 THEN GOTO OUT2;                                 <<02852>>03430000
                                                               <<00.05>>03432000
    TOS := DISKADR0.(8:8); << Double disk address of space >>  <<02852>>03434000
    TOS := DISKADR1;                                           <<02852>>03436000
                                                               <<00.05>>03438000
    TOS := ATTACHIO(LDEV,0,0,SBUFX,PTAPEFUNC,32767,            <<00.05>>03440000
                       DADR0,DADR1,%11);                       <<00.05>>03442000
                                                               <<00.05>>03444000
    DEL;                                                       <<00.05>>03446000
    IF TOS.IOSTAT<>GOODIO THEN GOTO OUT4;     << AN ERROR >>   <<00.05>>03448000
    ASSEMBLE(ADDS 128);   << FORM TARGET DATA BUFFER  >>       <<00.05>>03450000
                                                               <<00.05>>03452000
                                                               <<00.05>>03454000
       << GET NEXT BUFFER OF SPOOLED DATA >>                   <<00.05>>03456000
                                                               <<00.05>>03458000
READNEXT:                                                      <<00.05>>03460000
    TOS := ATTACHIO(SYSDISK, 0, 0,SBUFX,READFUNC,128,          <<00.05>>03462000
              DADR0, DADR1, %11 );   << BLOCKED, SBUFRS >>     <<00.05>>03464000
    DEL;    TOGGLE := 0;                                       <<00.05>>03466000
                                                               <<00.05>>03468000
    IF TOS.IOSTAT=GOODIO THEN                                  <<00.05>>03470000
      BEGIN                                                    <<00.05>>03472000
        I := SBUFX;  << INIT X FOR CHAR FETCHES >>             <<00.05>>03474000
                                                               <<00.05>>03476000
NEXTCHAR:                                                      <<00.05>>03478000
        TOS := SYSBUF( I );  << GET TWO CHARACTERS >>          <<00.05>>03480000
        IF NOT TOGGLE THEN TOS := TOS&LSR(8) ELSE I:=I+1;      <<00.05>>03482000
        TEMP := TOS.CHARMASK;                                  <<00.05>>03484000
                                                               <<00.05>>03486000
        IF ESCFLAG THEN << CHECK FOR ESC ";" OR ESC ":" >>     <<00.05>>03488000
          BEGIN                                                <<00.05>>03490000
            ESCFLAG := FALSE;                                  <<00.05>>03492000
            IF TEMP=";" OR TEMP=":" THEN GOTO DELCHAR;         <<00.05>>03494000
          END;                                                 <<00.05>>03496000
                                                               <<00.05>>03498000
        IF TEMP=CR OR TEMP=Y'C THEN << EOR OR EOM >>           <<00.05>>03500000
          BEGIN                                                <<00.05>>03502000
            IF NOT DELFLAG THEN  << NOT A DELETED REC >>       <<00.05>>03504000
              BEGIN                                            <<00.05>>03506000
                FWRITE(DFILE, IRBUF,-BCNT, 0 );                <<00.05>>03508000
                IF <> THEN GOTO OUT4;  << AN ERROR >>          <<00.05>>03510000
              END;                                             <<00.05>>03512000
                                                               <<00.05>>03514000
            ESCFLAG := DELFLAG := BCNT := 0;                   <<00.05>>03516000
                                                               <<00.05>>03518000
            IF TEMP=Y'C THEN  << END OF SPOOL OPERATION >>     <<00.05>>03520000
              BEGIN                                            <<00.05>>03522000
                RETURNCC := CCE;    << SET CCE >>              <<00.05>>03524000
                GOTO OUT4;                                     <<00.05>>03526000
              END;                                             <<00.05>>03528000
          END                                                  <<00.05>>03530000
        ELSE                                                   <<00.05>>03532000
          BEGIN                                                <<00.05>>03534000
            IF TEMP=%30 THEN  DELFLAG := TRUE; << DEL REC>>    <<00.05>>03536000
                                                               <<00.05>>03538000
            IF TEMP=%10 THEN  << CTRL H, CHAR DELETE >>        <<00.05>>03540000
              BEGIN                                            <<00.05>>03542000
DELCHAR:                                                       <<00.05>>03544000
                IF BCNT<>0 THEN  BCNT := BCNT - 1;             <<00.05>>03546000
              END                                              <<00.05>>03548000
                                                               <<00.05>>03550000
            ELSE IF NOT DELFLAG AND TEMP<>0                    <<00.05>>03552000
             AND TEMP<>%12 AND TEMP<>%21                       <<00.05>>03554000
             AND TEMP<>%23 AND TEMP<>%177 THEN <<SAVE CHAR >>  <<00.05>>03556000
              BEGIN << NOT A NULL, LF, XON, XOFF, RUBOUT >>    <<00.05>>03558000
                IF TEMP=%33 THEN ESCFLAG := TRUE;              <<00.05>>03560000
                                                               <<00.05>>03562000
                RBUF(BCNT) := TEMP;  << SAVE CHAR >>           <<00.05>>03564000
                IF BCNT=255 THEN GOTO OUT4; << REC TOO LONG >> <<00.05>>03566000
                BCNT := BCNT + 1;                              <<00.05>>03568000
              END;                                             <<00.05>>03570000
          END;                                                 <<00.05>>03572000
                                                               <<00.05>>03574000
        IF ITOGGLE<>255 THEN << NOT END OF BUFFER >>           <<00.05>>03576000
          BEGIN                                                <<00.05>>03578000
            ITOGGLE := ITOGGLE + 1;    << TOGGLE TOGGLE >>     <<00.05>>03580000
            GOTO NEXTCHAR;  << GET ANOTHER CHARACTER >>        <<00.05>>03582000
          END;                                                 <<00.05>>03584000
                                                               <<00.05>>03586000
        DADDR := DADDR + 1 D;                                  <<00.05>>03588000
        GOTO READNEXT;  << GET ANOTHER SPOOLED BUFFER >>       <<00.05>>03590000
        HELP;  << FOR HELP PLABEL *********************** >>   <<00.05>>03592000
      END;                                                     <<00.05>>03594000
                                                               <<00.05>>03596000
OUT4:                                                          <<00.05>>03598000
   Return'Disc'Space (sysdisk, diskadr, 128D);                 <<03506>>03600000
OUT2:                                                          <<00.05>>03602000
    RETURNSYSBUF(SBUFX);                                       <<00.05>>03604000
                                                               <<00.05>>03606000
OUT1:                                                          <<00.05>>03608000
    RESETCRITICAL(SAVECRITICAL);                               <<00.05>>03610000
    CC := RETURNCC;                                            <<00.05>>03612000
    ERROREXIT(PTINUMB, 0, 0 );                                 <<00.05>>03614000
  END;    << PTAPE - PAPER TAPE SPOOLING  >>                   <<00.05>>03616000
$PAGE "PRINT FILE INFO"                                        <<01549>>03618000
INTRINSIC FFILEINFO,FGETINFO,FCHECK;                           <<01794>>03620000
PROCEDURE PRINT'FILE'INFO(FILENUM);                            <<01549>>03622000
VALUE FILENUM;                                                 <<01549>>03624000
INTEGER FILENUM;                                               <<01549>>03626000
   BEGIN <<DISPLAY ALL INFORMATION ABOUT FILE 'FILENUM'>>      <<01549>>03628000
   DEFINE                                                      <<01549>>03630000
   AOPCOPY         = AOPTIONS.(3:1)#,       << FILE TO BE COPIED>>      03632000
   AOPNOWAIT       = AOPTIONS.(4:1)#,       << NO-WAIT I/O MODE >>      03634000
   AOPMULTAC       = AOPTIONS.(5:2)#,       << MULTI ACCESS MODE >>     03636000
   AOPGLOBALMULTAC = AOPTIONS.(5:1)#,       << GLOBAL MULTI ACCESS >>   03638000
   AOPINHIBITBUF   = AOPTIONS.(7:1)#,       << INHIBIT BUFFERING >>     03640000
   AOPACMODE       = AOPTIONS.(8:2)#,       << ACCESS MODE >>  <<01549>>03642000
   AOPSEMI         = (AOPACMODE = 2)#,                         <<01674>>03644000
   AOPLOCKING      = AOPTIONS.(10:1)#,      << DYNAMIC LOCKING >>       03646000
   AOPMULTIREC     = AOPTIONS.(11:1)#,      << MULTI-RECORD >> <<01549>>03648000
   AOPACTYPE       = AOPTIONS.(12:4)#;      << ACCESS TYPE >>  <<01549>>03650000
                                                               <<01549>>03652000
   DEFINE  <<FOPTIONS fields>>                                 <<01549>>03654000
   FOPFILETYPE   = FOPTIONS.(2:3)#,       << TYPE OF FILE >>   <<01549>>03656000
   FOPKSAMFILE   = (FOPFILETYPE=1)#,                           <<01567>>03658000
   FOPMSGFILE    = (FOPFILETYPE=6)#,                           <<01549>>03660000
   FOPNOEQUATE   = FOPTIONS.(5:1)#,       << NO FILE EQUATION >>        03662000
   FOPLABELLED   = FOPTIONS.(6:1)#,                            <<01549>>03664000
   FOPCONTROL    = FOPTIONS.(7:1)#,       << CARRIAGE CONTROL >>        03666000
   FOPFORMAT     = FOPTIONS.(8:2)#,       << RECORD FORMAT >>  <<01549>>03668000
   FOPDESIGNATOR = FOPTIONS.(10:3)#,      << DESIGNATOR >>     <<01549>>03670000
   FOPASCII      = FOPTIONS.(13:1)#,      << ASCII >>          <<01549>>03672000
   FOPDOMAIN     = FOPTIONS.(14:2)#;                           <<01549>>03674000
                                                               <<01549>>03676000
   INTEGER RECSIZE,DEVTYPE,FILECODE,BLKSIZE,NUMEXTENTS,DEVSTAT,<<01794>>03678000
           ERRORCODE,TLOG,NUMRECS,USERLABELS,NUMWRITERS,NUMREADERS;     03680000
   DOUBLE  BLKNUM,RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,        <<01549>>03682000
           DEXTSIZE:=0D,LABADDR;                               <<01674>>03684000
   INTEGER ECODE,X=X;                                          <<01674>>03686000
   LOGICAL FOPTIONS,AOPTIONS,LDNUM,DRT,UNIT,                   <<03051>>03688000
           EXTSIZE=DEXTSIZE+1;                                 <<01549>>03690000
   BYTE ARRAY                                                  <<01549>>03692000
      FILENAME(0:27),CREATORID(0:7),NUMWRITERSB(*)=NUMWRITERS, <<01549>>03694000
      NUMREADERSB(*)=NUMREADERS;                               <<01549>>03696000
   INTEGER ARRAY BUFFER(0:25);                                 <<01549>>03698000
   BYTE ARRAY LINE(*)=BUFFER;                                  <<01549>>03700000
   BYTE ARRAY DOMAIN(0:11)=PB:="NEWSYSJOBALL";                 <<01549>>03702000
   BYTE ARRAY RECFMT(0:7)=PB:=",F,V,U,?";                      <<01549>>03704000
   BYTE ARRAY FILEQUATION(0:7)=PB:=",FEQ,DEQ";                 <<01549>>03706000
   BYTE ARRAY FILE'TYPE(0:31)=PB:=                             <<01549>>03708000
      "    ,KSM,RIO,???,CIR,???,MSG,???";                      <<01549>>03710000
   BYTE ARRAY EXCL(0:15)=PB:=",DEF,EXC,XXX,SHR";               <<01549>>03712000
                                                               <<01549>>03714000
   DEFINE                                                      <<01549>>03716000
      DISABLE       = ASSEMBLE(SED 0)#,                        <<01549>>03718000
      ENABLE        = ASSEMBLE(SED 1)#,                        <<01549>>03720000
      CHECKDB       = DISABLE;                                 <<01549>>03722000
                      PUSH(DB);                                <<01549>>03724000
                      X:=ABSOLUTE(5)-5;                        <<01549>>03726000
                      TOS:=ABSOLUTE(X); X:=X+1; TOS:=ABSOLUTE(X);       03728000
                      ENABLE;                                  <<01549>>03730000
                      ASSEMBLE(DCMP)#,                         <<01549>>03732000
      PRINTINFOHANG = [10/21,6/1]#,                            <<01549>>03734000
      ILLEGALDB     = 1#;                                      <<01549>>03736000
                                                               <<01549>>03738000
   ENTRY PRINTFILEINFO;                                        <<01549>>03740000
                                                               <<01549>>03742000
   SUBROUTINE PRINTLINE;                                       <<01549>>03744000
      BEGIN <<SEND BUFFER TO $STDLIST>>                        <<01549>>03746000
      PRINT(BUFFER, -50, %40);                                 <<01549>>03748000
      END;  <<PRINTLINE>>                                      <<01549>>03750000
                                                               <<01549>>03752000
                                                               <<01549>>03754000
   SUBROUTINE BINCONV(N, FIELD, DIGITS);                       <<01549>>03756000
   VALUE N, DIGITS;                                            <<01549>>03758000
   INTEGER N,DIGITS;                                           <<01549>>03760000
   BYTE FIELD;                                                 <<01549>>03762000
      BEGIN <<CONVERT BINARY N TO BINARY FIELD (WIDTH=DIGITS)>><<01549>>03764000
      ASSEMBLE(LDX DIGITS;  LOAD N;                            <<01549>>03766000
      LOOP:DECX,NOP;  BL DONE;                                 <<01549>>03768000
           DUP;  ANDI 1;  ORI %60;                             <<01549>>03770000
           STB S-4,I,X;  <<FIELD(X):=TOS>>                     <<01549>>03772000
           LSR 1;  BR LOOP;                                    <<01549>>03774000
      DONE:DEL);                                               <<01549>>03776000
      END;  <<BINCONV>>                                        <<01549>>03778000
   SUBROUTINE MAKEROOM(ADDR,NEEDED);                           <<01549>>03780000
   VALUE ADDR,NEEDED;                                          <<01549>>03782000
   BYTE POINTER ADDR;                                          <<01549>>03784000
   INTEGER NEEDED;                                             <<01549>>03786000
      BEGIN                                                    <<01549>>03788000
      IF LOGICAL(@ADDR(NEEDED)) > LOGICAL(@LINE(47)) THEN      <<04489>>03790000
         BEGIN  <<MUST INDEX TO THE NEXT LINE>>                <<01549>>03792000
         PRINTLINE;                                            <<01549>>03794000
         MOVE LINE:=                                           <<01549>>03796000
            "!                                                !";       03798000
         @ADDR:=@LINE(13);                                     <<01549>>03800000
         END                                                   <<01549>>03802000
      ELSE                                                     <<01549>>03804000
         BEGIN  <<USE CURRENT LINE, INSERT COMMA>>             <<01549>>03806000
         ADDR:=",";                                            <<01549>>03808000
         @ADDR:=@ADDR+1;                                       <<01549>>03810000
         END;                                                  <<01549>>03812000
      RETURN 1;                                                <<01549>>03814000
      END;  <<MAKEROOM>>                                       <<01549>>03816000
   SUBROUTINE PRINTFOPTIONS;                                   <<01549>>03818000
      BEGIN                                                    <<01549>>03820000
      MOVE LINE:="!  FOPTIONS:                                     !";  03822000
      MOVE LINE(13):=DOMAIN(3*FOPDOMAIN),(3),2;                <<01549>>03824000
      <<BINARY OR ASCII>>                                      <<01549>>03826000
      IF FOPASCII THEN                                         <<01549>>03828000
         MOVE *:=",ASCII",2                                    <<01549>>03830000
      ELSE                                                     <<01549>>03832000
         MOVE *:=",BINARY",2;                                  <<01549>>03834000
      <<DEFAULT FILE DESIGNATOR>>                              <<01549>>03836000
      IF FOPDESIGNATOR <= 6 THEN                               <<01549>>03838000
         CASE FOPDESIGNATOR OF                                 <<01549>>03840000
            BEGIN                                              <<01549>>03842000
            MOVE *:=",FORMAL",2;                               <<01549>>03844000
            MOVE *:=",$STDLIST",2;                             <<01549>>03846000
            MOVE *:=",$NEWPASS",2;                             <<01549>>03848000
            MOVE *:=",$OLDPASS",2;                             <<01549>>03850000
            MOVE *:=",$STDIN",2;                               <<01549>>03852000
            MOVE *:=",$STDINX",2;                              <<01549>>03854000
            MOVE *:=",$NULL",2;                                <<01549>>03856000
            END;                                               <<01549>>03858000
      <<RECORD FORMAT>>                                        <<01549>>03860000
      MOVE *:=RECFMT(2*FOPFORMAT),(2),2;                       <<01549>>03862000
      <<CARRIAGE CONTROL>>                                     <<01549>>03864000
      IF FOPCONTROL THEN MOVE *:=",CCTL",2 ELSE MOVE*:=",NOCCTL",2;     03866000
      <<ALLOW FILE EQUATIONS>>                                 <<01549>>03868000
      MOVE *:=FILEQUATION(FOPNOEQUATE*4),(4),2;                <<01549>>03870000
      <<FILE TYPE>>                                            <<01549>>03872000
      IF FOPFILETYPE <> 0 THEN                                 <<01549>>03874000
         MOVE *:=FILE'TYPE(FOPFILETYPE*4),(4),2;               <<01549>>03876000
      IF FOPLABELLED THEN                                      <<01549>>03878000
         BEGIN  <<LABELED TAPE>>                               <<01549>>03880000
         MAKEROOM(*,5);                                        <<01549>>03882000
         MOVE *:="LABEL",2;                                    <<01549>>03884000
         END                                                   <<01549>>03886000
      ELSE                                                     <<01549>>03888000
         BEGIN                                                 <<01549>>03890000
         MAKEROOM(*,7);                                        <<01549>>03892000
         MOVE *:="NOLABEL",2;                                  <<01549>>03894000
         END;                                                  <<01549>>03896000
      DEL;                                                     <<01549>>03898000
      PRINTLINE;                                               <<01549>>03900000
      END;  <<PRINTFOPTIONS>>                                  <<01549>>03902000
                                                               <<01549>>03904000
                                                               <<01549>>03906000
   SUBROUTINE PRINTAOPTIONS;                                   <<01549>>03908000
      BEGIN                                                    <<01549>>03910000
      MOVE LINE:="!  AOPTIONS:                                     !";  03912000
      <<ACCESS TYPE>>                                          <<01549>>03914000
      TOS:=@LINE(13);                                          <<01549>>03916000
      IF AOPACTYPE <= 6 THEN                                   <<01549>>03918000
         CASE AOPACTYPE OF                                     <<01549>>03920000
            BEGIN                                              <<01549>>03922000
            MOVE *:="INPUT",2;                                 <<01549>>03924000
            MOVE *:="OUTPUT",2;                                <<01549>>03926000
            MOVE *:="OUTKEEP",2;                               <<01549>>03928000
            MOVE *:="APPEND",2;                                <<01549>>03930000
            MOVE *:="IN/OUT",2;                                <<01549>>03932000
            MOVE *:="UPDATE",2;                                <<01549>>03934000
            MOVE *:="EXECUTE",2;                               <<01549>>03936000
            END;                                               <<01549>>03938000
      <<MULTIRECORD ACCESS>>                                   <<01549>>03940000
      IF AOPMULTIREC THEN MOVE *:=",MR",2 ELSE MOVE *:=",NOMR",2;       03942000
      <<LOCKABLE>>                                             <<01549>>03944000
      IF AOPLOCKING THEN MOVE *:=",LOCK",2 ELSE MOVE *:=",NOLOCK",2;    03946000
      <<EXCLUSIVE OPTIONS>>                                    <<01549>>03948000
      IF AOPSEMI THEN                                          <<01549>>03950000
         MOVE *:=",SEMI",2                                     <<01549>>03952000
      ELSE                                                     <<01549>>03954000
         MOVE *:=EXCL(4*AOPACMODE),(4),2;                      <<01549>>03956000
      <<BUFFER OR NO-BUFFER>>                                  <<01549>>03958000
      IF AOPINHIBITBUF THEN MOVE *:=",NOBUF",2 ELSE MOVE *:=",BUF",2;   03960000
                                                               <<01549>>03962000
      <<MULTI ACCESS>>                                         <<01549>>03964000
      IF AOPMULTAC = 1 THEN                                    <<01549>>03966000
         BEGIN                                                 <<01549>>03968000
         MAKEROOM(*,5);                                        <<01549>>03970000
         MOVE *:="MULTI",2;                                    <<01549>>03972000
         END                                                   <<01549>>03974000
      ELSE IF AOPGLOBALMULTAC THEN                             <<01549>>03976000
         BEGIN                                                 <<01549>>03978000
         MAKEROOM(*,6);                                        <<01549>>03980000
         MOVE *:="GMULTI",2;                                   <<01549>>03982000
         END                                                   <<01549>>03984000
      ELSE                                                     <<01549>>03986000
         BEGIN                                                 <<01549>>03988000
         MAKEROOM(*,7);                                        <<01549>>03990000
         MOVE *:="NOMULTI",2;                                  <<01549>>03992000
         END;                                                  <<01549>>03994000
      IF AOPNOWAIT THEN                                        <<01549>>03996000
         BEGIN  <<NO WAIT>>                                    <<01549>>03998000
         MAKEROOM(*,6);                                        <<01549>>04000000
         MOVE *:="NOWAIT",2;                                   <<01549>>04002000
         END                                                   <<01549>>04004000
      ELSE                                                     <<01549>>04006000
         BEGIN                                                 <<01549>>04008000
         MAKEROOM(*,5);                                        <<01549>>04010000
         MOVE *:="WAIT",2;                                     <<01549>>04012000
         END;                                                  <<01549>>04014000
      IF AOPCOPY THEN                                          <<01549>>04016000
         BEGIN  <<COPY>>                                       <<01549>>04018000
         MAKEROOM(*,4);                                        <<01549>>04020000
         MOVE *:="COPY",2;                                     <<01549>>04022000
         END                                                   <<01549>>04024000
      ELSE                                                     <<01549>>04026000
         BEGIN                                                 <<01549>>04028000
         MAKEROOM(*,6);                                        <<01549>>04030000
         MOVE *:="NOCOPY",2;                                   <<01549>>04032000
         END;                                                  <<01549>>04034000
      DEL;                                                     <<01549>>04036000
      PRINTLINE;                                               <<01549>>04038000
      END;  <<PRINTAOPTIONS>>                                  <<01549>>04040000
                                                               <<01549>>04042000
                                                               <<01549>>04044000
   SUBROUTINE PRINTDETAILS;                                    <<01549>>04046000
      BEGIN                                                    <<01549>>04048000
      MOVE LINE:="!  FILE NAME IS ############################     !";  04050000
      MOVE LINE(16):=FILENAME,(28);                            <<01549>>04052000
      PRINTLINE;                                               <<01549>>04054000
                                                               <<01549>>04056000
      PRINTFOPTIONS;                                           <<01549>>04058000
      PRINTAOPTIONS;                                           <<01549>>04060000
                                                               <<01549>>04062000
      <<DEVICE>>                                               <<01549>>04064000
      MOVE LINE:="!  DEVICE TYPE: #      DEVICE SUBTYPE: #         !";  04066000
      ASCII(DEVTYPE.(8:8),10,LINE(16));                        <<01549>>04068000
      ASCII(DEVTYPE.(0:8),10,LINE(39));                        <<01549>>04070000
      PRINTLINE;                                               <<01549>>04072000
      MOVE LINE:="!  LDEV: #        DRT: #         UNIT: #         !";  04074000
      ASCII(LDNUM,10,LINE(9));                                 <<01549>>04076000
      FFILEINFO(FILENUM,47,DRT,48,UNIT);                       <<03051>>04078000
      ASCII(DRT,10,LINE(23));                                  <<03051>>04080000
      ASCII(UNIT,10,LINE(39));                                 <<03051>>04082000
      PRINTLINE;                                               <<01549>>04084000
                                                               <<01549>>04086000
      MOVE LINE:="!  RECORD SIZE: #      BLOCK SIZE: #     (WORDS) !";  04088000
      IF RECSIZE<0 THEN                                        <<01549>>04090000
         BEGIN <<FILE TYPE IS ASCII>>                          <<01549>>04092000
         MOVE LINE(42):="BYTES";                               <<01549>>04094000
         RECSIZE:=-RECSIZE;  BLKSIZE:=-BLKSIZE;                <<01549>>04096000
         END;                                                  <<01549>>04098000
      ASCII(RECSIZE,10,LINE(16));                              <<01549>>04100000
      ASCII(BLKSIZE,10,LINE(35));                              <<01549>>04102000
      PRINTLINE;                                               <<01549>>04104000
                                                               <<01549>>04106000
      MOVE LINE:=                                              <<01549>>04108000
         "!  EXTENT SIZE: #      MAX EXTENTS: #            !"; <<01549>>04110000
      DASCII (DEXTSIZE,10,LINE(16));                           <<01549>>04112000
      ASCII(NUMEXTENTS,10,LINE(36));                           <<01549>>04114000
      PRINTLINE;                                               <<01549>>04116000
                                                               <<01549>>04118000
      MOVE LINE:=                                              <<01549>>04120000
         "!  RECPTR: #           RECLIMIT: #               !"; <<01549>>04122000
      DASCII(RECPTR,10,LINE(11));                              <<01549>>04124000
      DASCII(FLIMIT,10,LINE(33));                              <<01549>>04126000
      PRINTLINE;                                               <<01549>>04128000
                                                               <<01549>>04130000
      MOVE LINE:=                                              <<01549>>04132000
         "!  LOGCOUNT: #            PHYSCOUNT: #           !"; <<01549>>04134000
      DASCII(LOGCOUNT,10,LINE(13));                            <<01549>>04136000
      DASCII(PHYSCOUNT,10,LINE(37));                           <<01549>>04138000
      PRINTLINE;                                               <<01549>>04140000
                                                               <<01549>>04142000
      MOVE LINE:=                                              <<01549>>04144000
         "!  EOF AT: #           LABEL ADDR: %#            !"; <<01549>>04146000
      DASCII(EOF,10,LINE(11));                                 <<01549>>04148000
      DASCII(LABADDR, 8, LINE(36));                            <<01549>>04150000
      PRINTLINE;                                               <<01549>>04152000
                                                               <<01549>>04154000
      MOVE LINE:=                                              <<01549>>04156000
         "!  FILE CODE: #      ID IS #         ULABELS: #  !"; <<01549>>04158000
      ASCII(FILECODE,10,LINE(14));                             <<01549>>04160000
      MOVE LINE(27):=CREATORID,(8);                            <<01549>>04162000
      ASCII(USERLABELS,10,LINE(46));                           <<01549>>04164000
      PRINTLINE;                                               <<01549>>04166000
                                                               <<01549>>04168000
      MOVE LINE:=                                              <<01549>>04170000
         "!  PHYSICAL STATUS: ????????????????             !"; <<01549>>04172000
      IF NOT FOPKSAMFILE AND DEVTYPE.(8:8) <> 16 THEN          <<01580>>04174000
         BEGIN                                                 <<01567>>04176000
         DEVSTAT:=DEVICESTATUS(LDNUM);                         <<01794>>04178000
         IF >= THEN BINCONV(DEVSTAT,LINE(20),16);              <<01794>>04180000
         PRINTLINE;                                            <<01567>>04182000
         END;                                                  <<01567>>04184000
      IF FOPMSGFILE THEN                                       <<01549>>04186000
         BEGIN  <<MESSAGE FILE, PRINT # READERS AND WRITERS>>  <<01549>>04188000
         FFILEINFO(FILENUM,34,NUMWRITERSB,35,NUMREADERSB);     <<01549>>04190000
         MOVE LINE:=                                           <<01549>>04192000
            "!  NUMBER WRITERS:     NUMBER READERS:           !";       04194000
         ASCII(NUMWRITERS,10,LINE(19));                        <<01549>>04196000
         ASCII(NUMREADERS,10,LINE(39));                        <<01549>>04198000
         PRINTLINE;                                            <<01549>>04200000
         END;                                                  <<01549>>04202000
      END;  <<PRINTDETAILS>>                                   <<01549>>04204000
                                                               <<01549>>04206000
                                                               <<01549>>04208000
PRINTFILEINFO:   <<UNPRIMED ENTRY POINT>>                      <<01549>>04210000
   ERRORON;                                                    <<01549>>04212000
   CHECKDB;                                                    <<01549>>04214000
   IF <> THEN ERROREXIT(PRINTINFOHANG,ILLEGALDB,0);            <<01549>>04216000
   <<SKIP A LINE AND PRINT HEADING>>                           <<01549>>04218000
   MOVE LINE:="  ";  PRINT(BUFFER, -1, %40);                   <<01549>>04220000
   MOVE LINE:="+-F-I-L-E---I-N-F-O-R-M-A-T-I-O-N---D-I-S-P-L-A-Y+";     04222000
   PRINTLINE;                                                  <<01549>>04224000
   FCHECK(FILENUM,ERRORCODE,TLOG,BLKNUM,NUMRECS);              <<01613>>04226000
   IF FILENUM <> 0 THEN                                        <<01549>>04228000
      BEGIN  <<PRINT ALL THE FILE INFORMATION>>                <<01549>>04230000
      FGETINFO(FILENUM,FILENAME,FOPTIONS,AOPTIONS,RECSIZE,DEVTYPE,LDNUM,04232000
      <<HDADDR>>,FILECODE,RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,<<03051>>04234000
      BLKSIZE,EXTSIZE,NUMEXTENTS,USERLABELS,CREATORID,LABADDR);<<03051>>04236000
      IF <> OR NOT STATUS.(0:1) AND (1 <= FILENUM <= 2) THEN   <<01580>>04238000
         BEGIN <<UNDEFINED FILE NUMBER>>                       <<01549>>04240000
         MOVE LINE:=                                           <<01549>>04242000
            "!  FILE NUMBER #      IS UNDEFINED.              !";       04244000
         ASCII(FILENUM,10,LINE(15));                           <<01549>>04246000
         PRINTLINE;                                            <<01549>>04248000
         FILENUM:=0;                                           <<01549>>04250000
         END                                                   <<01549>>04252000
      ELSE                                                     <<01549>>04254000
         PRINTDETAILS;                                         <<01549>>04256000
      END;                                                     <<01549>>04258000
                                                               <<01549>>04260000
   <<PRINT FILE CHECK INFORMATION>>                            <<01549>>04262000
   ECODE:=ERRORCODE.(8:8);                                     <<01549>>04264000
   MOVE LINE:="!  ERROR NUMBER: #     RESIDUE: #        (WORDS) !";     04266000
   ASCII(ECODE,10,LINE(17));                                   <<01549>>04268000
   IF TLOG=0 THEN                                              <<01549>>04270000
      MOVE LINE(41):="       "                                 <<01549>>04272000
   ELSE IF < THEN                                              <<01549>>04274000
      BEGIN TLOG:=-TLOG; MOVE LINE(42):="BYTES" END;           <<01549>>04276000
   ASCII(TLOG,10,LINE(32));                                    <<01549>>04278000
   PRINTLINE;                                                  <<01549>>04280000
                                                               <<01549>>04282000
   MOVE LINE:="!  BLOCK NUMBER: #            NUMREC: #          !";     04284000
   DASCII(BLKNUM,10,LINE(17));                                 <<01549>>04286000
   ASCII(NUMRECS,10,LINE(38));                                 <<01549>>04288000
   PRINTLINE;                                                  <<01549>>04290000
                                                               <<01549>>04292000
   MOVE LINE:="+------------------------------------------------+";     04294000
   PRINTLINE;                                                  <<01549>>04296000
   ERROREXIT(PRINTINFOHANG,0,0);                               <<01549>>04298000
   END;  <<PRINT'FILE'INFO>>                                   <<01549>>04300000
$PAGE "PROCEDURE LOG"                                          <<01711>>04302000
<< Procedure LOG was moved from segment Pcreate to Utility1 >> <<01711>>04304000
<< for MPE-IV (C-MIT) to reduce the length of Pcreate.      >> <<01711>>04306000
$CONTROL SEGMENT=UTILITY1                                      <<01711>>04308000
PROCEDURE LOG;                                                 <<01711>>04310000
OPTION UNCALLABLE;                                             <<01711>>04312000
                                                               <<01711>>04314000
COMMENT:                                                       <<01711>>04316000
         CHECKS IF LOG REQUIRED FOR THAT RECORD                <<01711>>04318000
         FORMATS LOG RECORD ACCORDING TO CATALOGUE             <<01711>>04320000
         OUTPUTS RECORD TO BUFFER                              <<01711>>04322000
         ACTIVATES LOG PROCESS IF BUFFER FULL                  <<01711>>04324000
         DB MAY BE POINTING ANYWHERE BUT HAS TO BE SPECIFIED   <<01711>>04326000
            IN CATALOGUE : FIRST WORD OF ENTRY .(0:2)          <<01711>>04328000
         ;                                                     <<01711>>04330000
                                                               <<01711>>04332000
BEGIN                                                          <<01711>>04334000
                                                               <<01711>>04336000
      INTEGER S0 = S-0;                                        <<01711>>04338000
                                                               <<01711>>04340000
      DEFINE                                                   <<01711>>04342000
        DISAPROC        = ASSEMBLE (PSDB)#,                    <<01711>>04344000
        ENAPROC         = ASSEMBLE (PSEB)#,                    <<01711>>04346000
        DISABLE         = ASSEMBLE (SED 0)#,                   <<01711>>04348000
        ENABLE          = ASSEMBLE (SED 1)#;                   <<01711>>04350000
                                                               <<01711>>04352000
      EQUATE                                                   <<01711>>04354000
                                                                        04356000
      PCBB        = 3,           <<PTR TO BASE OF PCB TABLE >> <<01711>>04358000
      CPCB        = 4,           <<PTR TO CURRENT PCB >>       <<01711>>04360000
      SYSDB       = 512,         <<SYSTEM DB OFFSET>>                   04362000
                                                                        04364000
      LOGPINX     = SYSDB+%150,  <<LOG PROCESS PCB INDEX>>              04366000
      LOGINFO     = SYSDB+%167,  <<LOGGING AREA>>                       04368000
      BUF0X       = SYSDB+%172,  <<BUFFER 0 DST NR.>>                   04370000
      BUF1X       = SYSDB+%173,  <<BUFFER 1 DST NR.>>                   04372000
      BUFSIZEX    = SYSDB+%174,  <<BUFFER SIZE (SECTORS)>>              04374000
      FREEX       = SYSDB+%175,  <<FREE AREA POINTER>>                  04376000
      FLAGX       = SYSDB+%176,  <<FLAG WORD>>                          04378000
      LOGREC0X    = SYSDB+%177,  <<BUFFER 0 RECORDS WRITTEN>>           04380000
      LOGREC1X    = SYSDB+%200,  <<BUFFER 1 RECORDS WRITTEN>>           04382000
      FILESIZE0X  = SYSDB+%201,  <<FILE SIZE (BLOCKS) - 1ST HALF>>      04384000
      FILESIZE1X  = SYSDB+%202,  <<FILE SIZE (BLOCKS) - 2ND HALF>>      04386000
      FNX         = SYSDB+%205,  <<FILE NUMBER>>                        04388000
      BLOCKS0X    = SYSDB+%206,  <<BLOCKS WRITTEN - 1ST HALF>>          04390000
      BLOCKS1X    = SYSDB+%207,  <<BLOCKS WRITTEN - 2ND HALF>>          04392000
      LOST0X      = SYSDB+%210,  <<TOTAL RECORDS LOST - 1ST HALF>>      04394000
      LOST1X      = SYSDB+%211,  <<TOTAL RECORDS LOST - 2ND HALF>>      04396000
      JINITLOSTX  = SYSDB+%212,  <<RECORDS LOST - JOB INITIATION>>      04398000
      JTERMLOSTX  = SYSDB+%213,  <<RECORDS LOST - JOB TERMINATION>>     04400000
                                                                        04402000
      EMPTY       = 0,           <<EMPTY BUFFER STATE>>                 04404000
      CURRENT     = 1,           <<CURRENT BUFFER STATE>>               04406000
      FULL        = 2,           <<FULL BUFFER STATE>>                  04408000
                                                                        04410000
      DIRSIR      = 8,           <<DIRECTORY SIR>>                      04412000
      DSIRX       = 2*DIRSIR,    <<SIR TABLE INDEX>>                    04414000
      BUFSIR      = 26,          <<LOG BUFFER SIR NR.>>                 04416000
      BSIRX       = 2*BUFSIR,    <<SIR TABLE INDEX>>                    04418000
      FILESIR     = 37,          <<FILE SYSTEM SIR NR.>>                04420000
      FSIRX       = 2*FILESIR,   <<SIR TABLE INDEX>>                    04422000
      MINSIZE     = 12,                                                 04424000
      LPROC       = 7,           <<SYS. PROC. NR. OF LOG PROC.>>        04426000
      PCBSIZE     = 16,           <<PCB SIZE (WORDS)>>                  04428000
      JN          = 19;          <<JOB TYPE AND NR. PCBX INDEX>>        04430000
                                                                        04432000
      INTEGER POINTER SIR = %14; <<SIR SYS. TABLE NR.>>                 04434000
                                                                        04436000
COMMENT:                                                       <<04594>>04438000
     The following is an explanation of the 3 words called     <<04594>>04440000
the logging mask found in SYSGLOB cells 167-171.  For each     <<04594>>04442000
rectype (Log Type) the corresponding bit in the correspond-    <<04594>>04444000
ing word is turned on (bit=1) if the logging for that          <<04594>>04446000
RECTYPE is enabled, and off (0) is not enabled.  RECTYPE 0     <<04594>>04448000
used to determine if system logging is enabled or disabled.    <<04594>>04450000
                                                               <<04594>>04452000
RECTYPE   Word  Bit          RECTYPE    Word   Bit             <<04594>>04454000
-------   ----  ---     |    -------    ----   ---             <<04594>>04456000
   0       0     15     |      25        1       6             <<04594>>04458000
   1       0     14     |      26        1       5             <<04594>>04460000
   2       0     13     |      27        1       4             <<04594>>04462000
   3       0     12     |      28        1       3             <<04594>>04464000
   4       0     11     |      29        1       2             <<04594>>04466000
   5       0     10     |      30        1       1             <<04594>>04468000
   6       0      9     |      31        1       0             <<04594>>04470000
   7       0      8     |      32        2      15             <<04594>>04472000
   8       0      7     |      33        2      14             <<04594>>04474000
   9       0      6     |      34        2      13             <<04594>>04476000
  10       0      5     |      35        2      12             <<04594>>04478000
  11       0      4     |      36        2      11             <<04594>>04480000
  12       0      3     |      37        2      10             <<04594>>04482000
  13       0      2     |      38        2       9             <<04594>>04484000
  14       0      1     |      39        2       8             <<04594>>04486000
  15       0      0     |      40        2       7             <<04594>>04488000
  16       1     15     |      41        2       6             <<04594>>04490000
  17       1     14     |      42        2       5             <<04594>>04492000
  18       1     13     |      43        2       4             <<04594>>04494000
  19       1     12     |      44        2       3             <<04594>>04496000
  20       1     11     |      45        2       2             <<04594>>04498000
  21       1     10     |      46        2       1             <<04594>>04500000
  22       1      9     |      47        2       0             <<04594>>04502000
  23       1      8     |      48  Out of Bounds               <<04594>>04504000
  24       1      7     |                                      <<04594>>04506000
=============================================================  <<04594>>04508000
;                                                              <<04594>>04510000
                                                                        04512000
                                                                        04514000
      ENTRY LOG1,                                                       04516000
            LOG2,                                                       04518000
            LOG3,                                                       04520000
            LOG4,                                                       04522000
            LOG5,                                                       04524000
            LOG6,                                                       04526000
            LOG7,                                                       04528000
            LOG8,                                                       04530000
            LOG9,                                                       04532000
            LOG10,                                                      04534000
      LOG11,                                                   <<01711>>04536000
      LOG12,                                                   <<01711>>04538000
      LOG13,                                                   <<01711>>04540000
      LOG14,                                                   <<01711>>04542000
      LOG15,                                                   <<01765>>04544000
      LOG16,                                                   <<04853>>04546000
      LOG17,  << X.21 Call Progress Signals >>                 <<04853>>04548000
      LOG18,  << X.21 DCE Provided Information >>              <<04853>>04550000
      LOG46,                                                   <<03104>>04552000
      LOG47;                                                   <<03104>>04554000
COMMENT                                                        <<01711>>04556000
   THE CATALOGUE CONSISTS OF 8-BYTE ENTRIES FOR EACH LOG TYPE: <<01711>>04558000
      1 ST BYTE.(0:2) = DB MODE AT CALL                        <<01711>>04560000
         0=STACK                                               <<01711>>04562000
         1=EXTRA DATA SEGMENT                                  <<01711>>04564000
         2=SYSTEM GLOBAL AREA                                  <<01711>>04566000
      1 ST BYTE.(2:6) = # OF PARAMETER WORDS                   <<01711>>04568000
         (COUNT FOR EXIT INSTRUCTION)                          <<01711>>04570000
      SUBSEQUENT FOUR-BIT ENTRIES DESCRIBE EACH PARAMETER:     <<01711>>04572000
         0=END OF PARAMETER LIST                               <<01711>>04574000
         1=WORD BY VALUE                                       <<01711>>04576000
         2=BYTE BY VALUE                                       <<01711>>04578000
         3=DOUBLEWORD BY VALUE                                 <<01711>>04580000
         4=TRIPLEWORD BY VALUE                                 <<01711>>04582000
         5=QUADRUPLE ARRAY BY REFERENCE                        <<01711>>04584000
         6=WORD ARRAY BY REFERENCE                             <<01711>>04586000
         7=BYTE ARRAY BY REFERENCE                             <<01711>>04588000
         8=27-BYTE ARRAY BY REFERENCE                          <<01711>>04590000
      ***WITH REFERENCE DATA, ADDR IN 1ST WORD, LENGTH         <<01711>>04592000
         IN SECOND WORD**************                          <<01711>>04594000
;                                                              <<01711>>04596000
      BYTE ARRAY CAT0(*)=PB := 5,%63,0,0,0,0,0,0;                       04598000
      BYTE ARRAY CAT1(*)=PB := 12,%61,%104,%60,0,0,0,0;                 04600000
      BYTE ARRAY CAT2(*)=PB := 13,%125,%125,%21,%21,%61,%20,0; <<01711>>04602000
      BYTE ARRAY CAT3(*)=PB := 7,%21,%63,0,0,0,0,0;                     04604000
      BYTE ARRAY CAT4(*)=PB := 6,%21,%21,%20,0,0,0,0;                   04606000
      BYTE ARRAY CAT5(*)=PB := 10,%201,%61,%63,0,0,0,0;                 04608000
      BYTE ARRAY CAT6(*)=PB := 4,%21,%20,0,0,0,0,0;                     04610000
      BYTE ARRAY CAT7(*)=PB := 2,%20,0,0,0,0,0,0;                       04612000
      BYTE ARRAY CAT8(*)=PB := %35,%104,%104,%104,%104,%101,   <<04205>>04614000
                               0,0;                            <<04205>>04616000
      BYTE ARRAY CAT9(*)=PB:=16,%23,%63,%21,%167,%160,0,0;     <<03104>>04618000
      BYTE ARRAY CAT10(*)=PB:=6,%24,%120,0,0,0,0,0;            <<03104>>04620000
      BYTE ARRAY CAT11(*)=PB := 14,%21,%21,%21,%21,%21,%23,0;           04622000
BYTE ARRAY CAT12(*)=PB:=5,%21,%140,0,0,0,0,0;                  <<01711>>04624000
BYTE ARRAY CAT13(*)=PB:=9,%21,%146,%140,0,0,0,0;               <<01711>>04626000
BYTE ARRAY CAT14(*)=PB:=3,%140,0,0,0,0,0,0;                    <<01711>>04628000
   BYTE ARRAY CAT15(*)=PB:=4,%27,0,0,0,0,0,0;                  <<01711>>04630000
   BYTE ARRAY CAT16(*)=PB:=6,%107,0,0,0,0,0,0;                 <<01765>>04632000
   BYTE ARRAY CAT17(*)=PB:=2,%20,0,0,0,0,0,0;                  <<04853>>04634000
   BYTE ARRAY CAT18(*)=PB:=4,%23,0,0,0,0,0,0;                  <<04853>>04636000
   BYTE ARRAY CAT19(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04638000
   BYTE ARRAY CAT20(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04640000
   BYTE ARRAY CAT21(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04642000
   BYTE ARRAY CAT22(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04644000
   BYTE ARRAY CAT23(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04646000
   BYTE ARRAY CAT24(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04648000
   BYTE ARRAY CAT25(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04650000
   BYTE ARRAY CAT26(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04652000
   BYTE ARRAY CAT27(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04654000
   BYTE ARRAY CAT28(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04656000
   BYTE ARRAY CAT29(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04658000
   BYTE ARRAY CAT30(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04660000
   BYTE ARRAY CAT31(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04662000
   BYTE ARRAY CAT32(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04664000
   BYTE ARRAY CAT33(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04666000
   BYTE ARRAY CAT34(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04668000
   BYTE ARRAY CAT35(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04670000
   BYTE ARRAY CAT36(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04672000
   BYTE ARRAY CAT37(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04674000
   BYTE ARRAY CAT38(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04676000
   BYTE ARRAY CAT39(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04678000
   BYTE ARRAY CAT40(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04680000
   BYTE ARRAY CAT41(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04682000
   BYTE ARRAY CAT42(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04684000
   BYTE ARRAY CAT43(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04686000
   BYTE ARRAY CAT44(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04688000
   BYTE ARRAY CAT45(*)=PB := 0,0,0,0,0,0,0,0;                  <<03104>>04690000
   BYTE ARRAY CAT46(*)=PB:=11,%21,%21,%21,%21,%160,0,0;        <<03104>>04692000
   BYTE ARRAY CAT47(*)=PB:=6,%21,%27,0,0,0,0,0;                <<03104>>04694000
<<>>                                                           <<01711>>04696000
   EQUATE NUMLOGS=47;                                          <<03104>>04698000
<<>>                                                           <<01711>>04700000
      ARRAY CATL(*)=CAT0(0);                                            04702000
      BYTE ARRAY BCAT(*)=CAT0(0);                                       04704000
      LOGICAL NEXIT;  <<SDEC FOR LOG EXIT>>                             04706000
      INTEGER BX;  <<BUFFER INDEX>>                                     04708000
      INTEGER PINX;  <<PIN FOR CURRENT PROCESS>>                        04710000
      INTEGER PARMX;  <<LOG PARAMETER INDEX>>                           04712000
      INTEGER N;  <<PARAMETER NR.>>                                     04714000
      INTEGER PTYPE;  <<PARAMETER TYPE NR.>>                            04716000
      INTEGER T;  <<UTILITY VARIABLE>>                                  04718000
      INTEGER TEMP;     <<TEMP VARIABLE USED FOR I/O LOGGING>> <<01711>>04720000
      INTEGER RECTYPE;  <<LOG RECORD TYPE NR.>>                         04722000
      INTEGER BSIZE;  <<BUFFER SIZE IN WORDS>>                          04724000
      INTEGER FREEP;  <<FREE BUFFER AREA INDEX>>                        04726000
      INTEGER CB;  <<CURRENT LOG BUFFER NR.>>                           04728000
      INTEGER ORIG'BUF;  <<CURRENT BUF WHEN ENTER LOG>>        <<01711>>04730000
      INTEGER DST;  <<BUFFER DST NR.>>                                  04732000
      INTEGER S;  <<FOR GETSIR>>                                        04734000
      INTEGER CR;  <<FOR SETCRITICAL>>                                  04736000
      LOGICAL SUSP := FALSE;                                            04738000
      LOGICAL LOGPF;  <<CALLING PROCESS IS LOG PROCESS?>>               04740000
      INTEGER DBMODE;  <<DB SETTING: 0=STACK,1=DATA SEG.,2=ABSOLUTE>>   04742000
      INTEGER INDEX'WORD,INDEX,OFFSET;                         <<04205>>04744000
      ARRAY PARMLIST(*)=Q+0;                                            04746000
      LOGICAL FULLF;                                                    04748000
      ARRAY PCBX(*)=Q+0;                                                04750000
<<>>                                                           <<01711>>04752000
         EQUATE BUFMAX=200;<<MAXIMUM LOG RECORD SIZE>>         <<01711>>04754000
<<  THIS VALUE SHOULD BE LARGE ENOUGH TO CONTAIN GOOD SIZE>>   <<01711>>04756000
<<  CONSOLE OPERATOR MESSAGES, SUCH AS, LARGE TELLOP'S    >>   <<01711>>04758000
<<  CONSOLE LOGGING MESSAGES LARGER THAN BUFMAX ARE TRUNCATED>><<01711>>04760000
<<>>                                                           <<01711>>04762000
         BYTE ARRAY BUFB(0:BUFMAX)=Q; <<INTERMEDIATE BUFFER>>  <<01711>>04764000
      ARRAY BUF(*)=BUFB;                                                04766000
      INTEGER CALENDARSTAMP = BUF+3;  <<DAY AND YEAR>>                  04768000
      DOUBLE CLOCKSTAMP = BUF+4;  <<TIME OF DAY>>                       04770000
                                                                        04772000
<<------------------------------------------------------------------->> 04774000
                                                                        04776000
INTEGER SUBROUTINE NEXTPTYPE (N);                                       04778000
   <<RETURNS THE PARAMETER TYPE NUMBER CORRESPONDING TO THE SPECIFIED   04780000
     PARAMETER NUMBER.                                                  04782000
                                                                        04784000
     INPUT VARIABLES:                                                   04786000
         N - PARAMETER NUMBER                                           04788000
                                                                        04790000
     OUTPUT VARIABLES:                                                  04792000
         NEXTPTYPE - PARAMETER TYPE NUMBER                              04794000
                                                                        04796000
   >>                                                                   04798000
   VALUE N;                                                             04800000
   INTEGER N;                                                           04802000
BEGIN                                                                   04804000
                                                               <<04205>>04806000
                                                               <<04205>>04808000
  <<********************************************************>> <<04205>>04810000
  << First obtain WORD index into CATL array based on the   >> <<04205>>04812000
  << value of RECTYPE and N.                                >> <<04205>>04814000
  <<********************************************************>> <<04205>>04816000
                                                               <<04205>>04818000
  INDEX := (RECTYPE * 4) + ((N+1) /4);                         <<04205>>04820000
  INDEX'WORD := CATL(INDEX);                                   <<04205>>04822000
                                                               <<04205>>04824000
  <<********************************************************>> <<04205>>04826000
  << Now, obtain proper 4 bit field of 16 bit word based on >> <<04205>>04828000
  << the current value of N.                                >> <<04205>>04830000
  <<********************************************************>> <<04205>>04832000
                                                               <<04205>>04834000
  OFFSET := N MOD 4;                                           <<04205>>04836000
  CASE * OFFSET  OF                                            <<04205>>04838000
    BEGIN                                                      <<04205>>04840000
      NEXTPTYPE := INDEX'WORD.(4:4);                           <<04205>>04842000
      NEXTPTYPE := INDEX'WORD.(8:4);                           <<04205>>04844000
      NEXTPTYPE := INDEX'WORD.(12:4);                          <<04205>>04846000
      NEXTPTYPE := INDEX'WORD.(0:4);                           <<04205>>04848000
    END;                                                       <<04205>>04850000
                                                               <<04205>>04852000
END;  << N E X T P T Y P E >>                                           04854000
                                                                        04856000
<<------------------------------------------------------------------->> 04858000
                                                                        04860000
SUBROUTINE FORMATLOGREC;                                                04862000
   <<FORMATS A LOG RECORD FROM THE PARAMETERS TO THE LOG PROCEDURE      04864000
     AND INSERTS THE RECORD INTO THE LOCAL BUFFER BUF>>                 04866000
      BEGIN                                                             04868000
                                                                        04870000
      <<* * * FORMAT COMMON PREFACE TO LOG RECORD * * *>>               04872000
                                                                        04874000
      BUF(1) := RECTYPE;  <<RECORD TYPE>>                               04876000
      CALENDARSTAMP := CALENDAR;  <<DAY AND YEAR>>                      04878000
      CLOCKSTAMP := CLOCK;  <<TIME OF DAY>>                             04880000
      TOS := 0;  <<DUMMY JOB TYPE AND NR.>>                             04882000
      IF NOT ABSOLUTE(ABSOLUTE(CPCB)+9).(6:1) THEN  <<USER PROCESS?>>   04884000
         BEGIN                                                          04886000
         PUSH(Q,DL);                                                    04888000
         ASSEMBLE(XCH,SUB;DUP,STAX;DECX,DECX);                          04890000
         TOS := -PCBX(X);                                               04892000
         TOS := JN;                                                     04894000
         ASSEMBLE(ADD,ADD;STAX);                                        04896000
         TOS := TOS+PCBX(X)  <<JOB TYPE AND NR.>>                       04898000
         END;                                                           04900000
      BUF(6) := TOS;  <<JOB TYPE AND NR.>>                              04902000
                                                                        04904000
      <<* * * FORMAT UNIQUE PART OF LOG RECORD * * *>>                  04906000
                                                                        04908000
      BX := 7;  <<INDEX IN LOCAL BUFFER>>                               04910000
      N := 1;  <<PARM. NR.>>                                            04912000
      DO BEGIN                                                          04914000
         PTYPE := NEXTPTYPE(N);  <<PARM. TYPE NR.>>                     04916000
         IF LOGICAL(PTYPE) > 8 THEN SUDDENDEATH(%41);  <<INVALID?>>     04918000
         CASE * PTYPE OF                                                04920000
            BEGIN                                                       04922000
                                                                        04924000
            <<0 - PARM. LIST TERMINATOR>>                               04926000
                                                                        04928000
            GO OUT;                                                     04930000
                                                                        04932000
            <<1 - 1 WORD BY VALUE>>                                     04934000
                                                                        04936000
            GO TO B;                                                    04938000
                                                                        04940000
            <<2 - 1 BYTE BY VALUE>>                                     04942000
                                                                        04944000
            GO TO B;                                                    04946000
                                                                        04948000
            <<3 - 2 WORDS BY VALUE>>                                    04950000
                                                                        04952000
            GO TO C;                                                    04954000
                                                                        04956000
            <<4 - 3 WORDS BY VALUE>>                                    04958000
                                                                        04960000
            BEGIN                                                       04962000
            BUF(BX) := PARMLIST(PARMX);                                 04964000
            BX := BX+1; PARMX := PARMX+1;                               04966000
C:          BUF(BX) := PARMLIST(PARMX);                                 04968000
            BX := BX+1; PARMX := PARMX+1;                               04970000
B:          BUF(BX) := PARMLIST(PARMX);                                 04972000
            BX := BX+1; PARMX := PARMX+1                                04974000
            END;                                                        04976000
                                                                        04978000
            <<5 - 4 WORDS BY REFERENCE>>                                04980000
                                                                        04982000
            BEGIN                                                       04984000
            TOS := PARMLIST(PARMX);                                     04986000
            MOVE BUF(BX) := *,(4);                                      04988000
            BX := BX+4;                                                 04990000
            PARMX := PARMX+1                                            04992000
            END;                                                        04994000
                                                                        04996000
            <<6 - WORD ARRAY BY REFERENCE>>                             04998000
                                                                        05000000
            BEGIN                                                       05002000
            TOS := PARMLIST(PARMX);  <<WORD ARRAY ADR.>>                05004000
            T := PARMLIST(PARMX := PARMX+1);                            05006000
            IF T>((BUFMAX/2)-BX) THEN T:=(BUFMAX/2)-BX;        <<01711>>05008000
            MOVE BUF(BX) := *,(T);                                      05010000
            BX := BX+T;                                                 05012000
            PARMX := PARMX+1                                            05014000
            END;                                                        05016000
                                                                        05018000
            <<7 - BYTE ARRAY BY REFERENCE>>                             05020000
                                                                        05022000
            BEGIN                                                       05024000
            TOS := PARMLIST(PARMX);  <<BYTE ARRAY ADR.>>                05026000
            T := PARMLIST(PARMX := PARMX+1);  <<LENGTH>>                05028000
            IF T>(BUFMAX-(BX*2)) THEN T:=BUFMAX-(BX*2);        <<01711>>05030000
            MOVE BUFB(BX&LSL(1)) := *,(T);                              05032000
            PARMX := PARMX+1;                                           05034000
            BX := BX+(T+1)&LSR(1)                                       05036000
            END;                                                        05038000
                                                                        05040000
            <<8 - 27 BYTE ARRAY BY REFERENCE>>                          05042000
                                                                        05044000
            BEGIN                                                       05046000
            TOS := PARMLIST(PARMX);                                     05048000
            MOVE BUFB(BX&LSL(1)) := *,(27);                             05050000
            PARMX := PARMX+1;                                           05052000
            BX := BX+14                                                 05054000
            END                                                         05056000
                                                                        05058000
            END;  <<OF CASE>>                                           05060000
         N := N+1  <<NEXT PARM. NR.>>                                   05062000
         END UNTIL ((N=15) OR (BX>(BUFMAX/2)));                <<01711>>05064000
                                                                        05066000
      <<* * * COMPLETE PREFACE INITIALIZATION * * *>>                   05068000
                                                                        05070000
OUT:  IF RECTYPE= 11                                           <<01711>>05072000
      THEN  BEGIN                                              <<01711>>05074000
            TEMP:= 0;                                          <<01711>>05076000
            DO BEGIN                                           <<01711>>05078000
               BUF(BX):= PARMLIST(PARMX);                      <<01711>>05080000
               BX:= BX+1;                                      <<01711>>05082000
               PARMX:= PARMX+1;                                <<01711>>05084000
               TEMP:= TEMP+1;                                  <<01711>>05086000
               END                                             <<01711>>05088000
            UNTIL TEMP>= INTEGER(BUF(7).(0:8));                <<01711>>05090000
            END;                                               <<01711>>05092000
      BUF := (BX-1)&LSL(1);  <<NR. OF BYTES IN BUFFER>>        <<01711>>05094000
      BUF(2) := BX-1;  <<RECORD LENGTH>>                                05096000
      BUF(BX) := -1  <<RECORD LINK>>                                    05098000
      END;  << F O R M A T L O G R E C >>                               05100000
<<------------------------------------------------------------------->> 05102000
                                                                        05104000
                                                                        05106000
                                                                        05108000
      << PROCEDURE BODY >>                                              05110000
LOG1:                                                                   05112000
LOG2:                                                                   05114000
LOG3:                                                                   05116000
LOG4:                                                                   05118000
LOG5:                                                                   05120000
LOG6:                                                                   05122000
LOG7:                                                                   05124000
LOG8:                                                                   05126000
LOG9:                                                                   05128000
LOG10:                                                                  05130000
LOG11:                                                         <<01711>>05132000
LOG12:                                                         <<01711>>05134000
LOG13:                                                         <<01711>>05136000
LOG14:                                                         <<01711>>05138000
   LOG15:                                                      <<01711>>05140000
LOG16:                                                         <<01765>>05142000
LOG17:                                                         <<04853>>05144000
LOG18:                                                         <<04853>>05146000
LOG46:                                                         <<03104>>05148000
LOG47:                                                         <<03104>>05150000
      LOGPF := FALSE;  <<PRESUMED NOT TO BE LOG PROCESS>>               05152000
      CR := SETCRITICAL;  <<SET CRITICAL MODE>>                         05154000
      RECTYPE := PARMLIST(-4);  <<RECORD TYPE NR.>>                     05156000
      IF LOGICAL(RECTYPE) > NUMLOGS THEN                       <<04223>>05158000
         BEGIN                                                 <<04223>>05160000
         SOFT'DEATH(%40); << LOG NUMBER GIVEN IS GREATER     >><<04223>>05162000
         RETURN;         << THAN THE HIGHEST ALLOWED LOG #.  >><<04223>>05164000
         END;                                                  <<04223>>05166000
                                                               <<04223>>05168000
<< EXTRACT FROM TABLES IN THIS PROCEDURE THE NUMBER OF   >>    <<04223>>05170000
<< PARAMETERS TO CUT BACK THE STACK.                     >>    <<04223>>05172000
      TOS := CATL(RECTYPE&LSL(2)).(2:6);  <<PARM. CUTBACK>>             05174000
                                                               <<03104>>05176000
      IF = THEN          <<IF TBL ENTRY IS 0 THEN SOFT'DEATH>  <<04223>>05178000
         BEGIN           <<ELSE JUST RETURN TO THE USER. THE >><<04223>>05180000
         SOFT'DEATH(%40); <<USER WILL NOT KNOW NOTHING HAS   >><<04223>>05182000
         RETURN;         <<BEEN LOGGED IS IF SYSTEM DOES NOT >><<04223>>05184000
         END;            <<CRASH.  THIS IS NO DIFFERENT THAN >><<04223>>05186000
                         <<IF THAT LOG TYPE IS NOT ENABLED.  >><<04223>>05188000
                                                               <<04223>>05190000
                                                               <<04223>>05192000
                                                               <<04223>>05194000
<<  I/O ERROR LOGGING CAN HAVE VARIABLE AMOUNT OF INFOR- >>    <<04223>>05196000
<<  MATION ON TOS.  PARMLIST(-5) GIVES THE NUMBER OF     >>    <<04223>>05198000
<<  ADDITIONAL WORDS TO CUT BACK THE STACK BY.           >>    <<04223>>05200000
                                                               <<04223>>05202000
      IF RECTYPE= 11 THEN  TOS:= TOS+PARMLIST(-5)+1;           <<03104>>05204000
      NEXIT := S0;  <<NB OF EXITS FROM LOG>>                            05206000
      PARMX := -TOS-3;  <<Q REL INDEX OF 1ST PARAM>>                    05208000
      DBMODE := CATL(RECTYPE&LSL(2)).(0:2);<<DB MODE AT CALL>> <<04223>>05210000
      PINX := (ABSOLUTE(CPCB)-ABSOLUTE(PCBB))/PCBSIZE;                  05212000
      <<WATCH OUT FOR FILE LABEL AND DIRECTORY SIRS>>                   05214000
      IF RECTYPE = 5 THEN  <<CHECK FOR POSSIBLE DEADLOCK>>              05216000
         IF SIR(FSIRX).(0:8) = PINX OR SIR(DSIRX).(0:8) = PINX THEN     05218000
            GO TO RET;  <<AVOID DEADLOCK>>                              05220000
  <<  check for logging being enabled/disabled  >>             <<04594>>05222000
      IF NOT ABSOLUTE(LOGINFO) THEN  <<NO LOGGING?>>                    05224000
         BEGIN                                                          05226000
   << check the softfail bit  >>                               <<04594>>05228000
         IF ABSOLUTE(FLAGX).(11:1) THEN  <<SUSPENDED?>>                 05230000
            BEGIN                                                       05232000
            SUSP := TRUE;                                               05234000
            GOTO L4                                                     05236000
            END;                                                        05238000
RET:     RESETCRITICAL(CR);                                             05240000
         TOS := %31400 LOR NEXIT;                                       05242000
         ASSEMBLE(XEQ 0)                                                05244000
         END;                                                           05246000
L4:                                                                     05248000
  <<  check logging mask to see if logging for the specified >><<04594>>05250000
  <<  log type (RECTYPE) is enabled/disabled .               >><<04594>>05252000
      IF NOT (ABSOLUTE(LOGINFO+RECTYPE&LSR(4))&LSR(RECTYPE MOD 16))     05254000
         THEN GOTO RET;  <<NO LOGGING FOR THAT RECORD?>>                05256000
                                                                        05258000
      IF SUSP THEN  <<SUSPENDED?>>                                      05260000
         BEGIN                                                          05262000
         TOS := ABSOLUTE(LOST0X); TOS := ABSOLUTE(X := X+1);            05264000
         TOS := TOS+1D;                                                 05266000
         ABSOLUTE(X) := TOS; ABSOLUTE(X := X-1) := TOS;                 05268000
         X := RECTYPE;                                                  05270000
         IF X = 2 OR X = 3 THEN  <<JOB INIT/TERM?>>                     05272000
            ABSOLUTE(X) := ABSOLUTE(LOST0X+X)+1;                        05274000
         GOTO RET                                                       05276000
         END;                                                           05278000
                                                                        05280000
      FULLF := FALSE;                                                   05282000
      FORMATLOGREC;                                                     05284000
      IF PINX = (ABSOLUTE(LOGPINX)/PCBSIZE) THEN  <<LOG PROCESS>>       05286000
         BEGIN                                                          05288000
         LOGPF := TRUE;  <<SET LOG PROCESS FLAG>>                       05290000
         DISAPROC;                                                      05292000
         TOS := SIR(BSIRX);  <<PIN INDEX HOLDING SIR>>                  05294000
         ENAPROC;                                                       05296000
         IF TOS <> 0 THEN GO RET;  <<ANOTHER PROCESS HAS THE SIR?>>     05298000
         END;                                                           05300000
      S := GETSIR(BUFSIR);  <<GET LOG BUFFER SIR>>                      05302000
      ORIG'BUF:=CB:= ABSOLUTE(FLAGX).(13:1); <<CURRENT BUFFER>><<01711>>05304000
L1:   DST := ABSOLUTE(BUF0X+CB).(6:10);  <<BUFFER DST>>                 05306000
      BSIZE := ABSOLUTE(BUFSIZEX)&LSL(7);  <<BUFFER SIZE IN WORDS>>     05308000
      FREEP := ABSOLUTE(FREEX);  <<FREE AREA INDEX>>                    05310000
      IF (BX+1) <= BSIZE-FREEP THEN  <<ROOM LEFT IN BUFFER?>>           05312000
         BEGIN                                                          05314000
                                                                        05316000
         <<SET DB TO STACK>>                                            05318000
                                                                        05320000
         CASE DBMODE OF                                                 05322000
            BEGIN                                                       05324000
                                                                        05326000
            ;                          <<DB AT STACK>>                  05328000
                                                                        05330000
L3:         TOS := EXCHANGEDB(0);      <<DB AT XTRA DATA SEGMENT>>      05332000
                                                                        05334000
            BEGIN                      <<DB IS SET IN ABSOLUTE MODE>>   05336000
            PUSH(DB);                                                   05338000
            RESETDB(-1);               <<TO DATA SEGMENT>>              05340000
            GOTO L3                                                     05342000
            END                                                         05344000
                                                                        05346000
            END;  <<END CASE>>                                          05348000
                                                                        05350000
         <<MOVE INFO INTO CURRENT BUFFER>>                              05352000
                                                                        05354000
         TOS := DST; TOS := FREEP;  <<TARGET DST AND OFFSET>>           05356000
         TOS := @BUF;  <<SOURCE ADR.>>                                  05358000
         TOS := BX+1;  <<COUNT>>                                        05360000
  << move information to be logged to buffer data seg.       >><<04594>>05362000
         ASSEMBLE(MTDS 2);  <<MOVE LOG RECORD>>                         05364000
         FREEP := TOS;  <<RESET FREE AREA POINTER>>                     05366000
         DEL;                                                           05368000
  << write back then number of records written if buffer.    >><<04594>>05370000
         ABSOLUTE(X) := ABSOLUTE(LOGREC0X+CB)+1;  <<LOG REC>>           05372000
                                                                        05374000
         <<RESET DB TO ORIG. VALUE>>                                    05376000
                                                                        05378000
         CASE DBMODE OF                                                 05380000
            BEGIN                                                       05382000
                                                                        05384000
            ;             <<TO STACK>>                                  05386000
                                                                        05388000
            BEGIN                      <<TO XTRA DATA SEGMENT>>         05390000
            ASSEMBLE(ZERO,XCH);                                         05392000
            EXCHANGEDB(*)                                               05394000
            END;                                                        05396000
                                                                        05398000
            BEGIN                      <<TO ABSOLUTE ADDRESS>>          05400000
            ASSEMBLE(ZERO,XCH);                                         05402000
            EXCHANGEDB(*);                                              05404000
            SETSYSDB;                                                   05406000
            SET(DB)                                                     05408000
            END                                                         05410000
                                                                        05412000
            END;  <<END CASE>>                                          05414000
                                                                        05416000
         IF BSIZE-FREEP > MINSIZE THEN  <<ROOM LEFT IN BUF?>>           05418000
            BEGIN                                                       05420000
            ABSOLUTE(FREEX) := FREEP-1;                                 05422000
            DISAPROC;                                          <<01711>>05424000
            RELSIR(BUFSIR,S);                                           05426000
            IF FULLF THEN                                      <<01711>>05428000
               BEGIN <<IF BUF STILL FULL AWAKE LOB PROC.>>     <<01711>>05430000
               IF ABSOLUTE(BUF0X+ORIG'BUF).(4:2) = FULL AND    <<01711>>05432000
                  ABSOLUTE(LOGINFO)                            <<01711>>05434000
               THEN AWAKE(ABSOLUTE(LOGPINX),%20,0);            <<01711>>05436000
               END;                                            <<01711>>05438000
            ENAPROC;                                           <<01711>>05440000
            GOTO RET                                                    05442000
            END;                                                        05444000
                                                                        05446000
L2:      DISABLE;                                                       05448000
         ABSOLUTE(BUF0X+CB).(4:2) := FULL;  <<FULL STATE>>              05450000
L5:      CB := (CB+1).(15:1);  <<SWITCH CURRENT BUFFER INDEX>> <<01711>>05452000
<<  set bit is FLAGX saying which buffer is current.         >><<04594>>05454000
         ABSOLUTE(FLAGX).(13:1) := CB;                                  05456000
         ABSOLUTE(FREEX) := 0;                                          05458000
         TOS := ABSOLUTE(BUF0X+CB);                                     05460000
         IF S0.(4:2) = CURRENT THEN SUDDENDEATH(%41);                   05462000
                                                                        05464000
         IF TOS.(4:2) = FULL THEN  <<DELAY?>>                           05466000
            BEGIN  << buffers are full >>                      <<04594>>05468000
  << check to see if system logging is enabled/disabled.   >>  <<04594>>05470000
            IF NOT ABSOLUTE(LOGINFO) THEN  <<NO LOGGING?>>              05472000
               BEGIN   << Logging is disabled >>               <<04594>>05474000
               ENABLE;                                                  05476000
               RELSIR(BUFSIR,S);  <<Release buffer SIR>>       <<04594>>05478000
               GO RET                                                   05480000
               END;                                                     05482000
            CB := (CB+1).(15:1);                                        05484000
            ABSOLUTE(FLAGX).(13:1) := CB;                               05486000
            ENABLE;                                                     05488000
            <<IF LOG PROCESS IS THE CALLER THEN IGORE LOG RECORD>>      05490000
            IF LOGPF THEN  <<LOG PROCESS IS CALLER?>>                   05492000
               BEGIN                                                    05494000
               RELSIR(BUFSIR,S);                                        05496000
               GO RET                                                   05498000
               END;                                                     05500000
            DELAY(1000D);                                               05502000
            DISABLE;                                           <<01711>>05504000
            GOTO L5                                            <<01711>>05506000
            END;                                                        05508000
                                                                        05510000
         ABSOLUTE(X).(4:2) := CURRENT;  <<CURRENT STATE>>               05512000
         ENABLE;                                                        05514000
         IF FULLF THEN GOTO L1;                                         05516000
         DISAPROC;                                             <<01711>>05518000
         RELSIR(BUFSIR,S);                                              05520000
         << IF THE ORIGNAL BUFFER IS STILL FULL THEN >>        <<01711>>05522000
         << AWAKE LOG PROCESS TO FLUSH BUFFER        >>        <<01711>>05524000
         IF ABSOLUTE(BUF0X+ORIG'BUF).(4:2) = FULL AND          <<01711>>05526000
            ABSOLUTE(LOGINFO)                                  <<01711>>05528000
         THEN AWAKE(ABSOLUTE(LOGPINX),%20,0);                  <<01711>>05530000
         ENAPROC;                                              <<01711>>05532000
         GOTO RET                                                       05534000
         END;                                                           05536000
                                                                        05538000
      IF FULLF THEN SUDDENDEATH(35);  <<SYSTEM ERROR>>         <<01711>>05540000
      FULLF := TRUE;                                           <<01711>>05542000
      GOTO L2;                                                 <<01711>>05544000
      HELP;   << FOR LINKING OF BREAKPOINTS >>                 <<01711>>05546000
                                                               <<01711>>05548000
                                                               <<01711>>05550000
END;  << L O G >>                                              <<01711>>05552000
$PAGE "OUTER BLOCK"                                            <<01711>>05554000
$CONTROL SEGMENT=MAIN                                          <<01711>>05556000
end.                                                           <<01711>>05558000
