*  PROGRAMMER - PAUL L. STENDAL
         OPEN     PLOC,CHEX,FCHEX,INOA,SEBN,%PEND,IAF,LBL,;
   T0,T1,SECT,P,UK,%FIN,#X1,#X3,#4,#1,#1U1,#X2,RP,;
   FLIMF09,LIMF09,CP,DDEF,%FIN1,%FIN2,%FIN3,I,J,K,L,M,IIAF,;
   FLIMC16,LIMC16,SHXBN,FHEXBIN,IFE,FEBCBIN,;
   TCBTD,TX,TSZ,Q,N,STORE,LOAD,MOVE,#LT,LT,LTBAD,VT,#4TMP,;
   FSBNHX,SBNHX,#BA,#WA,FLPTBL,LPTBL,TBLK,AST,FERRMSG,;
   CLSDO,CLSXX,KBF,OPNXX,RBF,RDXX,R10TMP,R8TMP,TXBDER,TXDCB,WRTDO,;
   FLOPEN,FPT%VLP,FSCAN,FTBLSRCH,OPENDCB,OUTBUFF,SCAN,SCN,;
   STKADR,SPDPNTR,TBLSRCH,%DEV,SKPCHR,SB,FLFNDVLP,FNDVLP,;
   BABUF,BATBL,DELIMS
UK       EQU      'P:SYSTEM:  UNRECOGNIZED KEY'
INOA     EQU      'P:SYSTEM:  IMPROPER # OF AFS'
CP       EQU      'P:SYSTEM:  CONFLICTING PARAMETER'
DDEF     EQU      'P:SYSTEM:  DBL DEF PARAMETER'
IFE      EQU      'P:SYSTEM:  INSTRUCTION FORMAT ERROR'
IAF      EQU      'P:SYSTEM:  ILLEGAL AF'
IIAF     EQU      'P:SYSTEM:  ILLEGAL INDIRECT AF'
#X1      SET      1                 INDEX
#X2      SET      2                 INDEX
#X3      SET      3                 ODD INDEX
#4       SET      11                ANY
#1       SET      12                EVEN
#1U1     SET      13                #1U1 (#1+1)
FCHEX    SET      0
FLIMF09  SET      0
FHEXBIN  SET      0
FEBCBIN  SET      0
FLPTBL   SET      0
#LT      SET      0
FSBNHX   SET      0
FERRMSG  SET      0
FLOPEN   SET      0
FSCAN    SET      0
FTBLSRCH SET      0
FLFNDVLP SET      0
T0       SET      1
T1       SET      2
PLOC     SET      %
P:PT0    CSECT    0
SECT(T0) SET      %
P:PT1    CSECT    1
SECT(T1) SET      %
         ORG      PLOC
TBLK     EQU      '                                     '
AST      EQU      '**********************************'
         PAGE
*  CHANGE CONTROL SECTIONS.
P:TOSECT CNAME
         PROC
LF       SET      %
         ORG      AF
         PEND
         PAGE
*  CHANGE THE PROTECTION TYPES OF P:SYSTEM'S CONTROL SECTIONS.
P:PT     CNAME
         PROC
P        SET      SCOR(AF,0,1,NORMAL)
         ERROR,3,NUM(AF)>0&P=0    IAF
T0       SET      P:S(P,1,1,2,1)
T1       SET      P:S(P,2,1,2,2)
         PEND
         PAGE
*  RETURN AF POINTED TO BY AF(1)+2.
P:S      FNAME
         PROC
         PEND     AF(AF(1)+2)
         PAGE
P:MAX    FNAME    0
P:MIN    FNAME    1
         PROC
         PEND     P:S((AF(1)>AF(2))=NAME,AF(1),AF(2))
         PAGE
*  RETURN AF(1), SET AF(1) TO AF(2) OR 1 IF NO AF(2).
P:FLAG   FNAME
         PROC
%FIN     SET      AF(1)
AF(1)    SET      AF(2)+(NUM(AF)=1)
         PEND     %FIN
         PAGE
P:CHAR   CNAME
         PROC
P        SET      S:KEYS(0,24,TAB,NL,CR,NULL,LNF)
LF       DO1      (P(2)&X'80')>0
TAB EQU ' '
         DO1      (P(2)&X'40')>0
NL       EQU      '
'
         DO1      (P(2)&X'20')>0
CR       EQU      '
'
         DO1      (P(2)&X'10')>0
NULL     EQU      ' '
         DO1      (P(2)&8)>0
LNF      EQU      ' '
         PEND
         PAGE
P:TCS    FNAME    24,(16,8),('  ',' ')
P:TCD    FNAME    56,(48,40,32,24,16,8),('      ','     ',;
                  '    ','   ','  ',' ')
         PROC
I        SET      S:NUMC(AF)
         PEND     I**NAME(1)+AF**NAME(2,I)+NAME(3,I)
         PAGE
P:DL     FNAME
         PROC
         LOCAL    I,J
J        SET      AF(1)**(32*(NUM(AF)=2))+AF(2)
I        DO       #LT
         GOTO,LT(I)=J    %PEND
         FIN
#LT      SET      #LT+1
I        SET      #LT
LT(I)    SET      J
%PEND    PEND     LTBAD+I*2-2
         PAGE
P:END    CNAME
         PROC
         DO1      NUM(AF)=1
         USECT    AF
         BOUND    8
LTBAD    DATA,8   LT
         PEND
         PAGE
P:DISP   CNAME
         PROC
         LOCAL    TCWA
TCBTD    SET      1
%FIN3    SET      1
LF(1)    EQU      %
TX       SET
N        DO       NUM(AF)
         DO       TCOR(S:C,AF(N))=1
TX       SET      TX,AF(N)
TCBTD    SET      TCBTD+S:NUMC(AF(N))
         ELSE
         DO       SCOR(AF(N,1),NOPRINT)
%FIN3    SET      0
         ELSE
         CONV,TCWA    AF(N)
         FIN
         FIN
         FIN
         DO       %FIN3>0
,,TCWA   P:PRINT,0 S:PT(TX)
         ELSE
PLOC     P:TOSECT SECT(1)
TCWA     TEXTC    S:PT(TX)
SECT(1)  P:TOSECT PLOC
         FIN
LF(2)    EQU      TCWA
         PEND
CONV     CNAME
         PROC
Q  SET S:KEYS(2,20,LZ,*24,BUF,BTD,*SIZE,27,HEX,DEC,X,HEXX,*31,TRNSLT)
   ERROR,3,(Q(2)&X'C0')=0|(Q(2)&X'1F')=0    IAF,': AF(',P:BD(N),')'
   ERROR,3,AFA(Q(3),2)|AFA(Q(4),2)|AFA(Q(5),2)|AFA(Q(5),3)         ;
                  IIAF,': AF(',P:BD(N),')'
         GOTO,(Q(2)&X'12')=0    LBL
TSZ      SET      P:S(NUM(AF(Q(5)))=3,AF(Q(5),2)*2,AF(Q(5),3))
TX       SET    TX,P:S(Q(2)&2,P:BLANKS(TSZ),,('X''',P:BLANKS(TSZ),''''))
         P:BINHEX (BTD,TCBTD+(Q(2)&2)),(SIZE,TSZ),;
         (BUF,CF(2)),(SUB),(BIN,#BA(AF(Q(3),2))+AF(Q(4),2))
TCBTD    SET      TCBTD+3*((Q(2)&2)>0)+TSZ
         GOTO     %PEND
LBL      DO       (Q(2)&8)>0
         DO1      (#1U1=AF(Q(3),2)&(Q(2)&X'40')=0)=0
         LOAD     #1U1,(AF(Q(5),2),WA(AF(Q(3),2))+#WA(AF(Q(4),2)),;
                  #BA(AF(Q(3),2))+BA(AF(Q(4),2))),AF(Q(5),2)
TSZ      SET  P:S(NUM(AF(Q(5)))=3,P:S(AF(Q(5),2),3,3,5,8,10),AF(Q(5),3))
         DO       TSZ>1&(Q(2)&X'800')=0
         LW,1     SECT(T1)
         MBS,0    BA(=X'00405C00')+1
PLOC     P:TOSECT SECT(T1)
         GEN,8,24 TSZ-1,BA(CF(2))+TCBTD
SECT(T1) P:TOSECT PLOC
         FIN
         DO       (Q(2)&X'800')>0
         P:BINDEC (BIN,#1U1),(BUF,CF(2)),(BTD,TCBTD),(SIZE,TSZ),(LZ)
         ELSE
         P:BINDEC (BIN,#1U1),(BUF,CF(2)),(BTD,TCBTD),(SIZE,TSZ)
         FIN
TCBTD    SET      TCBTD+TSZ
         ELSE
         LW,#1U1  SECT(T1)
         MBS,#1U1 #BA(AF(Q(3),2))+AF(Q(4),2)-BA(CF(2))-TCBTD
         GOTO,(Q(2)&1)=0    PLOC
         LW,1     SECT(T1)
         TBS,0    P:S(NUM(AF(Q(6)))=1,AF(Q(6),2),LPTBL)
PLOC     P:TOSECT SECT(T1)
         GEN,8,24 AF(Q(5),2),BA(CF(2))+TCBTD
         GOTO,P:S(NUM(AF(Q(6)))=1,1,P:FLAG(FLPTBL))|(Q(2)&4)>0 LBL
LPTBL    EQU      %
 TEXT '..............................................................',;
   '.. ...........<(+|&.........|%*);.-/.........,%.>...........:#@''=.'
 TEXT '................................................................'
 TEXT '.ABCDEFGHI.......JKLMNOPQR........STUVWXYZ......0123456789......'
LBL,SECT(T1) P:TOSECT PLOC
TCBTD    SET      TCBTD+AF(Q(5),2)
         FIN
TX       SET      TX,P:BLANKS(P:S((Q(2)&5)>0,TSZ,AF(Q(5),2)))
%PEND    PEND
#BA      FNAME
         PROC
         PEND     P:S(TCOR(AF,1),BA(AF),4*AF)
#WA      FNAME
         PROC
         PEND     P:S(TCOR(AF,1),WA(AF),AF/4)
LOAD     CNAME    2
STORE    CNAME    5
MOVE     CNAME    0
         PROC
   ERROR,3,NAME>0&AF(3)>4    'P:SYSTEM:  FIELD LENGTH > 4: AF(',P:BD(I),')'
         DO       (NAME>0|(ABSVAL(AF(1,3))&3)=0)&(ABSVAL(AF(2,3))&3)=0;
                  &(AF(3)=1|AF(3)=2|AF(3)=4)
J        DO       NAME=0
         GEN,4,4,4,20,4,4,4,20    7-(AF(3)&6),2,#X3,AF(1,2),;
                                  7-(AF(3)&6),5,#X3,AF(2,2)
         ELSE
         GEN,4,4,4,20  7-(AF(3)&6),NAME,AF(1),AF(2,2)
         FIN
         ELSE
         DO1      NAME=2&AF(3)<4
         LI,AF(1) 0
  LW,#X3   =AF(3)**24+P:S(NAME**-1,AF(2,3),AF(1)*4+4-AF(3),AF(2,3))
         MBS,#X3  P:S(NAME**-1,AF(1,3),AF(2,3),AF(1)*4+4-AF(3))-;
                  P:S(NAME**-1,AF(2,3),AF(1)*4+4-AF(3),AF(2,3))
         FIN
         PEND
         PAGE
*  GENERATE ADD, COMPARE, LOAD, OR MULTIPLY INSTRUCTION--
*  IMMEDIATE OPERAND IF AF ISN'T INDIRECT, ELSE WORD ADDRESS OPERAND.
*  NOTHING GENERATED IF INDIRECT TO SAME REGISTER AND LOAD INSTRUCTION.
*        P:LI,REG AF
P:AI     CNAME    X'20'
P:CI     CNAME    X'21'
P:LI     CNAME    X'22'
P:MI     CNAME    X'23'
         PROC
LF       DO1      P:S(TCOR(AF(1),1),0,(CF(2)=AF(1)&NAME=X'22'&AFA(1)))=0
         GEN,8,4,20    NAME+AFA(1)*X'10',CF(2),AF(1)
         PEND
         PAGE
*  LOAD OR STORE WORD UNLESS LW,X  X OR STW,X  X; THEN NOTHING.
P:LW     CNAME    X'32'
P:STW    CNAME    X'35'
         PROC
LF       DO1      AFA(1)|(CF(2)=AF(1))=0
         GEN,1,7,4,20    AFA(1),NAME,CF(2),AF(1)
         PEND
         PAGE
*  ANALYZE AF, CHECK FOR KEYWORDS, BUILD LIST SPECIFYING RESULTS.
*        P:KEYS((CMNDKEYFLD),KEY1,KEY2,KEY3,...,KEYN)
P:KEYS   FNAME
         PROC
         LOCAL    I,J,K
RP       SET      0
I        DO       NUM(AF(1))
J        DO       NUM(AF)-1
K        SET      SCOR(AF(1,I,1),AF(J+1))
         GOTO,K=0    %FIN2
         ERROR,3,RP(J,1)=K    DDEF,': AF(',P:BD(I),')'
         ERROR,3,RP(J,1)~=K&RP(J,1)>0    CP,': AF(',P:BD(I),')'
         GOTO,RP(J,1)~=0    %FIN1
RP(J)    SET      K,I
RP(1,3,I)   SET   J
         GOTO     %FIN1
%FIN2    FIN
         ERROR,3  UK,': AF(',P:BD(I),')'
%FIN1    FIN
         PEND     RP
         PAGE
P:BD     FNAME    '0','1','2','3','4','5','6','7','8','9'
         PROC
         PEND     S:PT(P:S(AF>9,,P:BD(AF/10)),NAME(AF-AF/10*10+1))
P:BH     FNAME    '0','1','2','3','4','5','6','7','8','9','A','B',;
                  'C','D','E','F'
         PROC
         PEND     S:PT(P:S(AF>15,,P:BH(AF/16)),NAME(AF-AF/16*16+1))
         PAGE
P:BLANKS FNAME
         PROC
%FIN     SET      ' '
         DO1      AF(1)-1
%FIN     SET      %FIN,' '
         PEND     S:PT(%FIN)
         PAGE
*  PROVIDE SYMBOLIC REGISTER DEFINITIONS.
P:REGDEF CNAME
         PROC
LF       EQU      %
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         PEND
         PAGE
*  BUILD LCI, PLW, PSW, PLM, AND/OR PSM FOR STACK OPERATIONS.
P:PSM    CNAME    X'B',9
P:PLM    CNAME    X'A',8
         PROC
P        SET      P:S((NUM(CF)=2)*8+(NUM(AF)>1)*4+(NUM(AF)>0)*2+;
   (NUM(AF(1))>1),(0,16),,(AF(1),1),(AF(1,1),AF(1,2)-AF(1,1)+1),,,;
   (AF(2),AF(1)),,(CF(2),1),,(CF(2),AF(1)))
         ERROR,3,(P(1)=0)&(P(2)=0)    IFE
P(2)     SET      P:S(P(2)<0,P:S(P(2)=16,P(2)),P(2)+16)
LF       DO1      P(2)~=1
         LCI      P(2)
         GEN,8,4,20    NAME((P(2)=1)+1),P(1),TSTACK
         PEND
         PAGE
*  GENERATE FORTRAN-LIKE SUBROUTINE CALLING SEQUENCE.
P:CALL   CNAME
         PROC
         DO1      TCOR(AF(1),S:FR)
         REF      AF(1)
LF       LI,14    NUM(AF)-1
         BAL,15   AF(1)
P        DO       NUM(AF)-1
 GEN,1,7,24 AFA(P+1),TCOR(AF(P+1),S:EXT,S:SUM)=0,WA(AF(P+1))
         FIN
         PEND
         PAGE
*  GENERATE MOVE OR COMPARE BYTE STRING INSTRUCTION SEQUENCE
P:MOVE   CNAME    X'61'
P:MBS    CNAME    X'61'
P:COMP   CNAME    X'60'
P:CBS    CNAME    X'60'
         PROC
P        SET      S:KEYS(2,*27,*FROM,*TO,SIZE,TEXTC)
         ERROR,3,NUM(AF)<2|NUM(AF)>3|AFA(P(3),2)|AFA(P(4),2)         IFE
         DO       (P(2)&2)>0
LF(1)    LI,#1U1  BA(AF(P(4),2))
         LB,#1    WA(AF(P(3),2))
         STB,#1   #1U1
         GEN,8,4,20    NAME,#1U1,BA(WA(AF(P(3),2)))+1-BA(AF(P(4),2))
         ELSE
         DO       AFA(P(5),2)
LF(1)    LI,#1U1  BA(AF(P(4),2))
         DO       P:S(TCOR(AF(P(5),2),1),,AF(P(5),2)<16)
         STB,AF(P(5),2)    #1U1
         ELSE
         LW,#1    AF(P(5),2)
         STB,#1   #1U1
         FIN
         ELSE
LF(1)    LW,#1U1  =AF(P(5),2)**24+BA(AF(P(4),2))
         FIN
         GEN,8,4,20    NAME,#1U1,BA(AF(P(3),2))-BA(AF(P(4),2))
         FIN
         PEND
         PAGE
*  GENERATE CAL1,2, FPT, AND TEXTC.
P:MESSAGE CNAME   0
P:PRINT  CNAME    1
P:TYPE   CNAME    2
         PROC
         DO       NAME=1
         DO1      TCOR(M:LL,S:FR)
         REF      M:LL
         ELSE
         DO1      TCOR(M:OC,S:FR)
         REF      M:OC
         FIN
LF(1)    CAL1,2   SECT(T1)
PLOC     P:TOSECT SECT(T1)
VT       SET      P:S(NUM(CF)=2,T1,(CF(2)=1)+1)
LF(2)    GEN,8,25,63    NAME,1,SECT(VT)+3*(VT=T1)
SECT(T1) P:TOSECT SECT(VT)
LF(3)    TEXTC    AF
SECT(VT) P:TOSECT PLOC
         PEND
         PAGE
*  ANALYZE I-O ERROR AND ABNORMAL RETURNS.
P:ABNERR CNAME    1,2,3,4,5,6,7,8,9,10,11,12,19,20,21,22,23,24,28,29,;
  46,63,64,65,66,67,68,69,70,71,73,74,81,84,85,86,87,X'75'
         PROC
         LOCAL    I,J,K,L,N
LF       LB,#1    10
Q        SET      P:KEYS((AF),1,2,3,(BOF,4),(EOD,TM,5),(EOF,6),;
   (LOSTDATA,7),8,9,A,B,C,13,14,15,16,17,18,(EOT,1C),(BOT,1D),;
   3E,3F,40,(READERR,41),42,43,44,(WRITERR,45),46,47,(NODRIVE,49),;
   4A,51,54,55,56,(NODISC,57),75,(EXIT,ERROR,ABORT,ELSE,MERC),END,;
   ERRMSG)
N        SET      NUM(NAME)
         GOTO,Q(N+2,1)=0    I
         CLM,#1   P:DL(5,6)
         BCR,9    AF(Q(N+2,2),2)
I        DO       NUM(AF)
         GOTO,Q(1,3,I)>N    %FIN
         CI,#1    NAME(Q(1,3,I))
         BE       AF(I,2)
%FIN     FIN
         DO1      Q(N+3,1)
         P:ERRMSG
         GOTO,Q(N+1,1)+1    %PEND,J,J,J,L,K
L        B        AF(Q(N+1,2),2)
         GOTO     %PEND
J        CAL1,9   Q(N+1,1)
         GOTO     %PEND
K        CAL1,2   =X'10000000'
%PEND    PEND
         PAGE
*  GENERATE MBS,0 TO ZERO, BLANK, OR * A BUFFER AREA.
*        P:ZERO   (BUF,ADDR),(SIZE,VALUE),(BTD,VALUE)
*        P:BLANK  (BUF,ADDR),(SIZE,VALUE),(BTD,VALUE)
P:ZERO   CNAME    0
P:BLANK  CNAME    1
P:STAR   CNAME    2
         PROC
P        SET      S:KEYS(2,*29,*BUF,*SIZE,BTD)
LF       LW,1     =AF(P(4),2)**24+BA(AF(P(3),2))+AF(P(5),2)
         MBS,0    BA(=X'00405C00')+NAME
         PEND
         PAGE
*  CONVERT SINGLE-PRECISION BINARY TO EBCDIC INTEGER.
*        P:BINEBC (BIN,ADDR),(BUF,ADDR),(BTD,VALUE),(SIZE,VALUE)
P:BINDEC CNAME
P:BINEBC CNAME
         PROC
P        SET      S:KEYS(2,*27,*BIN,BUF,BTD,*SIZE,31,(LZ,NOLZ))
         LOCAL    I
LF       P:LW,#1U1    AF(P(3),2)
         LI,#4    AF(P(6),2)
         LI,#X1   BA(AF(P(5),2))+AF(P(6),2)-1
I        LI,#1    0
         DW,#1    =10
         AI,#1    '0'
         STB,#1   AF(P(4),2),#X1
         DO       (P(2)&1)=0
         CI,#1U1  0
         BEZ      %+3
         FIN
         AI,#X1   -1
         BDR,#4   I
         PEND
         PAGE
*  CONVERT SINGLE-PRECISION BINARY TO EBCDIC HEX.
*        P:BINHEX (BIN,ADDR),(BUF,ADDR),(BTD,VALUE),(SIZE,VALUE)
P:BINHEX CNAME
         PROC
P        SET      S:KEYS(2,*25,*BIN,BUF,BTD,*SIZE,30,SUB,(NOLZ,LZ))
    DO       AF(P(6),2)>8|AFA(P(6),2)|(P(2)&2)>0|AFA(P(4),2)|AFA(P(5),2)
LF       P:LI,#X1 BA(AF(P(3),2))
         DO       AFA(P(4),2)|AFA(P(5),2)
%FIN     SET      2
         DO       (P(2)&X'20')>0
%FIN     SET      0
         DO       AFA(P(4),2)
         LW,#X2   AF(P(4),2)
         SLS,#X2  2
         ELSE
         LI,#X2   BA(AF(P(4),2))
         FIN
         FIN
         DO1      (P(2)&X'10')>0
         GEN,4,4,4,20    2+AFA(P(5),2),%FIN,#X2,WA(AF(P(5),2))
         ELSE
         LI,#X2   BA(AF(P(4),2))+BA(AF(P(5),2))
         FIN
         P:LI,#4  AF(P(6),2)
         BAL,#1   SBNHX+7*(AFA(P(6),2)=0&AF(P(6),2))
         GOTO,P:FLAG(FSBNHX)    %FIN
PLOC     P:TOSECT SECT(T1)
         AI,#X1   1
         AI,#X2   1
SBNHX    LB,#X3   0,#X1
         SLS,#X3  -4
         LB,#X3   CHEX,#X3
         STB,#X3  0,#X2
         BDR,#4   %+2
         B        *#1
         AI,#X2   1
         LB,#X3   0,#X1
         AND,#X3  =X'F'
         LB,#X3   CHEX,#X3
         STB,#X3  0,#X2
         BDR,#4   SBNHX-2
         B        *#1
SECT(T1) P:TOSECT PLOC
         ELSE
         LOCAL    I
LF       P:LW,#1U1    AF(P(3),2)
         LI,#4    AF(P(6),2)
         LI,#X1   BA(AF(P(5),2))+AF(P(6),2)-1
I        LW,#X3   #1U1
         AND,#X3  =X'F'
         LB,#X3   CHEX,#X3
         STB,#X3  AF(P(4),2),#X1
         AI,#X1   -1
         SLS,#1U1 -4
         DO       P(2)&1
         LW,#X3   #1U1
         BEZ      %+2
         FIN
         BDR,#4   I+(P(2)&1)
%FIN     FIN
         GOTO,P:FLAG(FCHEX)    %PEND
PLOC     P:TOSECT SECT(T1)
CHEX     TEXT     '0123456789ABCDEF'
SECT(T1) P:TOSECT PLOC
%PEND    PEND
         PAGE
*  CONVERT EBCDIC INTEGER TO SINGLE-PRECISION BINARY.
*        P:EBCBIN (BIN,ADDR),(BUF,ADDR),(BTD,VALUE),(SIZE,VALUE),
*                 (ERR,ADDR),(ERROR),(ABORT)
P:DECBIN CNAME    X'020',X'049',X'049'
P:EBCBIN CNAME    X'020',X'049',X'049'
         PROC
P    SET    S:KEYS(2,*24,NULL,*BIN,BUF,BTD,*SIZE,ERR,30,ABORT,ERROR)
         DO       SCOR(AF(P(7),2),TEXTC)
LF       LI,#X1   1
         LB,#1    AF(P(5),2)
         DO1      (P(2)&X'80')>0
         BEZ      AF(P(3),2)
         ELSE
LF       P:LI,#X1 AF(P(6),2)
         P:LI,#1  AF(P(7),2)
         FIN
         P:LI,#X3     AF(P(5),2)
         BAL,#X2  SEBN
         DO       (P(2)&4)>0
         B        AF(P(8),2)
         ELSE
         GEN,12,20    NAME((P(2)&3)+1),((P(2)&3)+1)
         FIN
         P:STW,#1U1   AF(P(4),2)
         GOTO,P:FLAG(FEBCBIN)    %PEND
PLOC     P:TOSECT SECT(T1)
SEBN     LI,#1U1  0
         LB,#4    *#X3,#X1
         CI,#4    X'40'
         BE       %+6
         CLM,#4   LIMF09
         BCS,9    0,#X2
         AI,#4    -'0'
         MI,#1U1  10
         AW,#1U1  #4
         AI,#X1   1
         BDR,#1   %-9
         B        1,#X2
         GOTO,P:FLAG(FLIMF09)    LBL
         BOUND    8
LIMF09   DATA     '0','9'
LBL      BOUND    1
SECT(T1) P:TOSECT PLOC
%PEND    PEND
         PAGE
*  CONVERT EBCDIC HEX TO SINGLE-PRECISION BINARY.
*        P:HEXBIN (BIN,ADDR),(BUF,ADDR),(BTD,VALUE),(SIZE,VALUE)
*                 (ERR,ADDR),(ERROR),(ABORT)
P:HEXBIN CNAME    X'020',X'049',X'049'
         PROC
P    SET    S:KEYS(2,*24,NULL,*BIN,BUF,BTD,*SIZE,ERR,30,ABORT,ERROR)
         DO       SCOR(AF(P(7),2),TEXTC)
LF       LI,#X1   1
         LB,#1    AF(P(5),2)
         DO1      (P(2)&X'80')>0
         BEZ      AF(P(3),2)
         ELSE
LF       P:LI,#X1 AF(P(6),2)
         P:LI,#1  AF(P(7),2)
         FIN
         P:LI,#X3     AF(P(5),2)
         BAL,#X2  SHXBN
         DO       (P(2)&4)>0
         B        AF(P(8),2)
         ELSE
         GEN,12,20    NAME((P(2)&3)+1),(P(2)&3)+1
         FIN
         P:STW,#1U1   AF(P(4),2)
         GOTO,P:FLAG(FHEXBIN)    %PEND
PLOC     P:TOSECT SECT(T1)
SHXBN    LI,#1U1  0
         LB,#4    *#X3,#X1
         CLM,#4   LIMF09
         BCR,9    %+6
         CI,#4    X'40'
         BE       %+7
         CLM,#4   LIMC16
         BCS,9    0,#X2
         AI,#4    X'FA'-X'C1'
         AI,#4    -'0'
         SLS,#1U1 4
         AW,#1U1  #4
         AI,#X1   1
         BDR,#1   %-12
         B        1,#X2
         BOUND    8
LIMC16   DATA     'A','F'
         DO1      P:FLAG(FLIMF09)=0
LIMF09   DATA     '0','9'
SECT(T1) P:TOSECT PLOC
%PEND    PEND
         PAGE
P:ERRMSG CNAME
         PROC
LF       BAL,#4   P:ERRMSG
         GOTO,P:FLAG(FERRMSG)    %PEND
         LOCAL    I,J,K,L,N
N        DO1      TCOR(M:DO,S:FR)
         REF      M:DO
         DO1      TCOR(M:XX,S:FR)
         REF      M:XX
         DO1      TCOR(J:DCBLINK,S:FR)
         REF      J:DCBLINK
P:ERRMSG DSECT    T1=2
         STW,#4   #4TMP
         LH,#1    M:XX
         CI,#1    X'20'
         BAZ      %+2
         CAL1,1   CLSXX
         LI,#1U1  X'1FFFF'
         LW,#1    8
         AI,#1    -1
         STS,#1   R8TMP
         LW,#1    10
         STS,#1   R10TMP
         SLD,#1   -24
         SLS,#1   1
         SLD,#1   7
         MTB,3    #1
         STW,#1   KBF
         CAL1,1   OPNXX
         CAL1,1   RDXX
         LW,#1U1  M:XX+13
         AI,#1U1  -2
J        CAL1,1   WRTDO
         LW,#1U1  =16**24+BA(RBF)+2
         MBS,#1U1 BA(TXDCB)-BA(RBF)-2
         P:BINHEX (BIN,BA(R8TMP)+1),(SIZE,5),(BUF,RBF),(BTD,5),(SUB)
         LI,#1U1  10
         AI,10    0
         BLEZ     L
         LW,#1    R10TMP
         BLEZ     L
         LW,#X2   J:DCBLINK
         B        %+2
K        AW,#X2   #X3
         AI,#X2   1
         LB,#X3   *#X2
         BEZ      L
         AI,#X3   4
         SLS,#X3  -2
         CW,#1    *#X2,#X3
         BNE      K
         LB,#X1   *#X2
         SLS,#X2  2
         LI,#1U1  BA(RBF)+18
         STB,#X1  #1U1
         LW,#1    #X2
         MBS,#1   1
         SW,#1U1  =BA(RBF)+1        IN CASE LOADED INTO LIBRARY
L        CAL1,1   WRTDO
         CAL1,1   CLSDO
         CAL1,1   CLSXX
         B        *#4TMP
I        CAL1,1   SETXX
         LW,#1U1  =20**24+BA(RBF)+2
         MBS,#1U1 BA(TXBDER)-BA(RBF)-2
         LI,#1U1  21
         B        J
OPNXX    GEN,8,24 X'14',M:XX
         DATA     X'C1000009',I,I,1,X'01000202'
         TEXTC    'ERRMSG'
         DATA     X'02010202',':SYS','    '
RDXX     GEN,8,24 X'10',M:XX
         DATA     X'38000010',RBF,80,KBF
CLSXX    GEN,8,24 X'15',M:XX
         DATA     X'80000000',2
SETXX    GEN,8,24 6,M:XX
         DATA     X'C0000000',,
WRTDO    GEN,8,24 X'11',M:DO
         DATA     X'34000010',RBF,1**31+#1U1,1
CLSDO    GEN,8,24 X'15',M:DO
         DATA     X'80000000',2
TXDCB    TEXT     'AT       ON DCB'
TXBDER   TEXT     'BAD ERRMSG FILE READ'
P:ERMSG0 DSECT    0
RBF      TEXT     ' '
         RES      20-%+RBF
KBF      RES      1
R8TMP    DATA
R10TMP   DATA
#4TMP    RES      1
         USECT    N
%PEND    PEND
         PAGE
P:DATA   CNAME
         PROC
         BOUND    P:S(NUM(CF)=2,4,P:S(CF(2)=8,4,8))
LF       DATA,P:S(NUM(CF)-1,4,CF(2))    NUM(AF),AF
         PEND
         PAGE
*  SCAN BUF, STOPPING ON SPECIFIED DELIMITERS, TRANSFERRING FIELD TO
*  OUTBUF IN TEXTC, TAKING SPECIFIED ACTION AT END OF FIELD.
P:SCAN   CNAME    0
P:SCANSU CNAME    1
         PROC
P        SET      S:KEYS(2,*26,DELIM,BUF,BTD,OUTBUF,END,SIZE,;
                  *22,LAST,LC,BIAS,STCF,*16,SKIP,SCANPT)
TX       SET      SCOR(AF(P(8),2),TEXTC)
TSZ      SET      SCOR(AF(P(8),2),TEXTC)
LF(1)    EQU      %
         GOTO,(P(2)&X'20')=0    LBL
         P:LI,#X2 AF(P(3),2)
         STW,#X2  DELIMS
LBL      GOTO,(P(2)&X'8000')=0    LBL
         P:LI,#1U1    AF(P(13),2)
         STW,#1U1 SKPCHR
LBL      GOTO,(P(2)&X'18')=0    LBL
         DO       AFA(P(4),2)|AFA(P(5),2)
         DO       AFA(P(4),2)
         P:LW,#X3 AF(P(4),2)
         SLS,#X3  2
         ELSE
         LI,#X3   BA(AF(P(4),2))+TSZ
TSZ      SET      0
         FIN
         DO       ((P(2)&8)>0)|TSZ
         DO       AFA(P(5),2)
         GEN,8,4,20    X'30',#X3,AF(P(5),2)  AW, NO *
         DO1      TSZ
         AI,#X3   1
         ELSE
         AI,#X3   AF(P(5),2)+TSZ
         FIN
         FIN
         ELSE
         LI,#X3   BA(WA(BA(AF(P(4),2))+AF(P(5),2)))+TX
         FIN
         STW,#X3  SPDPNTR
LBL      GOTO,(P(2)&4)=0    LBL
         P:LI,#1  AF(P(6),2)
         STW,#1   OUTBUFF
LBL      GOTO,(P(2)&1)=0    LBL
         DO       SCOR(AF(P(8),2),TEXTC)
         DO       (P(2)&X'10')>0
         LB,#4    WA(AF(P(4),2))
         ELSE
         DO       NUM(AF(P(8)))=3
         LB,#4    AF(P(8),3)
         ELSE
         LW,#4    SPDPNTR
         SLS,#4   -2
         LB,#4    *#4
         FIN
         FIN
         DO       (P(2)&8)>0
         DO       AFA(P(5),2)
         GEN,8,4,20    X'38',#4,AF(P(5),2)  SW, NO *
         ELSE
         AI,#4    -AF(P(5),2)
         FIN
         FIN
         ELSE
         P:LI,#4  AF(P(8),2)
         FIN
         SLS,#4   16
         DO1      (P(2)&X'80')>0
         P:AI,#4  AF(P(11),2)
         STW,#4   SPDPNTR+1
LBL      GOTO,NAME=1    %FIN
         BAL,#4   SCAN
         DO1      (P(2)&2)>0
         BCS,1    AF(P(7),2)
         DO1      (P(2)&X'200')>0
         BCS,4    AF(P(9),2)
         DO1      (P(2)&X'100')>0
         LC       AF(P(10),2),#X3
         DO1      (P(2)&X'40')>0
         STCF     AF(P(12),2)
         GOTO,P:FLAG(FSCAN)    %FIN
         LOCAL    I,J,K
PLOC     P:TOSECT SECT(T1)
SCAN     LW,#X3   =1**31
         STS,#X3  SPDPNTR+1
         STB,#X3  *OUTBUFF
         LI,#1    X'7FFF'
         AH,#1    SPDPNTR+1
         BNC      *#4
         LI,#1U1  K
         LI,#1    1
         BAL,#X1  SB
         BE       %-1
I        LB,#X3   *DELIMS
         CB,#X2   *DELIMS,#X3
         BE       J
         BDR,#X3  %-2
         B        *#1U1
K        MTB,1    *OUTBUFF
         LB,#X1   *OUTBUFF
         STB,#X2  *OUTBUFF,#X1
         BAL,#X1  SB
         BNE      I
         LI,#1U1  J+2
SB       LW,#X2   SPDPNTR
         MSP,#1   SPDPNTR
         BSO      *#4
         LB,#X2   0,#X2
         CW,#X2   SKPCHR
         B        0,#X1
J        BAL,#X1  SB
         BE       %-1
         LI,#X2   -1
         MSP,#X2  SPDPNTR
         B        *#4
SECT(T1) P:TOSECT SECT(1)
         BOUND    8
SPDPNTR  DATA     ,
OUTBUFF  DATA
DELIMS   DATA
SKPCHR   DATA     ' '
SECT(1)  P:TOSECT PLOC
%FIN     BOUND    1
LF(2)    EQU      SPDPNTR
AF(P(14),2) EQU   SPDPNTR
%PEND    PEND
         PAGE
P:SCANBR CNAME
         PROC
P        SET      S:KEYS(2,*28,END,LAST,LC,STCF)
LF       DO1      (P(2)&8)>0
         BCS,1    AF(P(3),2)
         DO1      (P(2)&4)>0
         BCS,4    AF(P(4),2)
         DO1      (P(2)&2)>0
         LC       AF(P(5),2),#X3
         DO1      P(2)&1
         STCF     AF(P(6),2)
         PEND
         PAGE
*  BUILD PARAMETER TABLE FOR P:SCAN (SPDPNTR, OUTBUFF, DELIMS, SKIP).
P:SCANPT CNAME
         PROC
P   SET   S:KEYS(2,*26,DELIM,BUF,BTD,OUTBUF,BIAS,SIZE,*20,SKIP)
         ERROR,3,AFA(P(3),2)|AFA(P(4),2)|AFA(P(5),2)|AFA(P(6),2);
                  |AFA(P(7),2)|AFA(P(8),2)|AFA(P(9),2)    IIAF
LF       EQU      %
         BOUND    8
         DO       (P(2)&X'1B')>0
         DO       SCOR(AF(P(8),2),TEXTC)
   GEN,32,16,16   BA(WA(BA(AF(P(4),2))+AF(P(5),2)))+1,0,AF(P(7),2)
         ELSE
   GEN,32,16,16   BA(AF(P(4),2))+AF(P(5),2),AF(P(8),2),AF(P(7),2)
         FIN
         FIN
         DO1      (P(2)&X'824')>0
         DATA     WA(AF(P(6),2)),WA(AF(P(3),2)),;
                  P:S((P(2)&X'800')>0,' ',AF(P(9),2))
         PEND
         PAGE
P:TC     CNAME    0
P:TX     CNAME    1
         PROC
         BOUND    4
LF       DO1      SCOR(C,CF)>0
         DATA     NUM(AF)
I        DO       NUM(AF)*(NAME=0)
         TEXTC    AF(I)
         FIN
I        DO       NUM(AF)*(NAME=1)
         TEXT     AF(I)
         FIN
         DO1      SCOR(0,CF)>0
         DATA     0
         PEND
         PAGE
*  SEARCH TEXTC TABLE FOR MATCH WITH TEXTC STRING, RETURN STRING COUNT.
P:SEARCH CNAME
         PROC
P        SET      S:KEYS(2,*25,BUF,TABLE,ERR,COUNT,B)
LF       EQU      %
         GOTO,(P(2)&X'40')=0    LBL
         P:LI,#X1 BA(AF(P(3),2))
         STW,#X1  BABUF
LBL      DO       (P(2)&X'20')>0
         P:LI,#X3 BA(AF(P(4),2))
         STW,#X3  BATBL
         FIN
         BAL,#X2  TBLSRCH
         DO       (P(2)&X'10')>0
         B        AF(P(5),2)
         ELSE
         NOP
         FIN
         DO1      (P(2)&8)>0
         P:STW,#X1    AF(P(6),2)
         DO1      (P(2)&4)>0
         B        AF(P(7),2),#X1
         GOTO,P:FLAG(FTBLSRCH)    %PEND
         LOCAL    I
PLOC     P:TOSECT SECT(T1)
TBLSRCH  LW,#X1   BABUF
         LB,#X3   0,#X1
         AI,#X3   1
         STB,#X3  BABUF
         LI,#X1   1
         LW,#X3   BATBL
I        LB,#4    0,#X3
         BEZ      0,#X2
         LW,#1    #X3
         LW,#1U1  BABUF
         CBS,#1   0
         BE       1,#X2
         AI,#X1   1
         AW,#X3   #4
         AND,#X3  =X'FFFFFFFC'
         AI,#X3   4
         B        I
SECT(T1) P:TOSECT SECT(1)
BATBL    RES      1
BABUF    RES      1
SECT(1)  P:TOSECT PLOC
%PEND    PEND
         PAGE
P:FNDVLP CNAME    (5,4,,3),(11,6)
         PROC
P        SET      S:KEYS(2,*24,FPARAM,FLP,VLP,*TYPE,*ENTADR,NONE,ERROR)
%FIN1    SET      NAME(1,P(2)**-5)
         DO       AFA(P(%FIN1),2)
         P:LW,#X1 AF(P(%FIN1),2)
         DO1      %FIN1]=5
         LW,#X1   NAME(2,%FIN1-2),#X1
         ELSE
         LI,#X1   AF(P(%FIN1),2)+NAME(2,%FIN1-2)
         FIN
         DO       AFA(P(6),2)
         LW,#1    AF(P(6),2)
         ELSE
%FIN1    SET      SCOR(AF(P(6),2),FILE,ACN,PASS,EXPIRE,READ,WRITE,SN,;
   OUTSN,,MODATE,SYNON,,SIZE,CRDATE,ACDATE,BUDATE,)
         LI,#1    P:S(%FIN1>0,AF(P(6),2),%FIN1)
         FIN
         BAL,#X3  FNDVLP
         P:STW,#X1    AF(P(7),2)
         DO       (P(2)&X'18')=X'18'&(AF(P(8),2)=AF(P(9),2))
         BNE      AF(P(8),2)
         ELSE
         DO1      (P(2)&X'10')>0
         BG       AF(P(8),2)
         DO1      (P(2)&8)>0
         BL       AF(P(9),2)
         FIN
         GOTO,P:FLAG(FLFNDVLP)    %PEND
         LOCAL    I
PLOC     P:TOSECT SECT(T1)
FNDVLP   LW,#4    #X1
         AI,#4    89
I        LW,#1U1  0,#X1
         CB,#1    #1U1
         BE       0,#X3
         CW,#1U1  =X'FF0000'
         BANZ     0,#X3
         AND,#1U1 =X'FF'
         AI,#1U1  1
         AW,#X1   #1U1
         CW,#4    #X1
         BGE      I
         B        0,#X3
SECT(T1) P:TOSECT PLOC
%PEND    PEND
         PAGE
P:OPEN   CNAME
         PROC
LF(1)    EQU      %
P   SET   S:KEYS(7,*0,ERR,ABN,BUF,RECL,TRIES,(ORG,CONSEC,KEYED,RANDOM),;
   (ACS,SEQUEN,DIRECT),(MODE,IN,OUT,INOUT,OUTIN),#,(FIL1,REL,SAVE),;
   FPARAM,TLABEL,KEYM,#,BTD,VOL,NEWX,SPARE,#,RSTORE,;
   21,NXTF,29,NXTA,NOSEP,CYLINDER)
Q        SET      S:KEYS(7,*20,INBUF,*ERROR,FPTBUF,STACK,SIZE,SCANDISP,;
                  28,NOCAL1,TEXTC,SCANPT)
         ERROR,3,P(1)+Q(1)~=NUM(AF)-1    UK
PLOC     P:TOSECT SECT(T0)
LF(3)    GEN,1,7,3,4,17,32    AFA(1),X'14',P(2)&7,,AF(1),0
J    SET    (AF(P(3),2),17),(AF(P(4),2),17),(AF(P(5),2),17),;
  (AF(P(6),2),16),(AF(P(7),2),8),(SCOR(AF(P(8),1),CONSEC,KEYED,;
  RANDOM),2),(SCOR(AF(P(9),1),SEQUEN,DIRECT),2),;
  (SCOR(AF(P(10),1),IN,OUT,,INOUT,,,,OUTIN),4),,;
  (SCOR(AF(P(12),1),REL,SAVE),2),(AF(P(13),2),17),(AF(P(14),2),17),;
  (AF(P(15),2),5),(0,0),(AF(P(17),2),2),(AF(P(18),2),8),(AF(P(19),2)**8;
  +AF(P(19),3),16),(AF(P(20),2),16),,(AF(P(22),2),20)
P(2)     SET      P(2)&X'400'
K        DO       20
         GOTO,(P(K+2)=NUM(AF)+1)&(K~=14) %FIN
         DO1      K=14
%DEV     SET      %
P(2)     SET      P(2)|1**(32-K)
         DO       AFA(P(K+2),2)
         PZE      AF(P(K+2),2)
         ELSE
         GEN,32-J(K,2),J(K,2)    0,J(K,1)
         FIN
%FIN     FIN
%FIN     SET      %
         ORG,4    SECT(T0)+1
         DATA     P(2)
         ORG,4    %FIN
         DATA,2   %-SECT(T0),%DEV-SECT(T0)+1
         DO       (Q(2)&2)>0
         MSP,#1U1 SPDPNTR
         ELSE
         DO       (Q(2)&X'40')>0
         AWM,#1U1 AF(Q(8),2)
         ELSE
         NOP
         FIN
         FIN
SECT(T0) P:TOSECT PLOC
         DO       AFA(Q(6),2)
         P:LI,#X3 AF(Q(6),2)
         STW,#X3  STKADR
         FIN
         LI,#X3   SECT(T0)-2
         LCI      0
         PSM,0    *STKADR
         DO       (Q(2)&2)>0
         LW,4     SPDPNTR
         INT,12   SPDPNTR+1
         ELSE
         DO       AFA(Q(3),2)
         GEN,12,20 X'324',AF(Q(3),2)
         ELSE
         LI,4     BA(AF(Q(3),2))+((Q(2)&X'80')=0)
         FIN
         DO       (Q(2)&X'80')>0
         P:LI,12  AF(Q(7),2)
         ELSE
         DO       AFA(Q(3),2)
         LB,12    *4
         SLS,4    2
         AI,4     1
         ELSE
         LB,12    AF(Q(3),2)
         FIN
         FIN
         FIN
         BAL,6    OPENDCB
   GEN,1,7,24 AFA(Q(5),2),P:S((Q(2)&X'200')>0,X'72',X'32'),AF(Q(5),2)-1
         B        AF(Q(4),2)
         DO1      (Q(2)&8)=0
         CAL1,1   *FPT%VLP
         GOTO,P:FLAG(FLOPEN)    %FIN
         OPEN     CHKEND,ERTRN,CC%REG6,SCN,TBL1,RET,SETDEV,TXDEV,;
 TXSNS,%6,%1,%2,%3,%4,%5,%8,%9,#DEV,I,J,K,REG4,CHTBL,#DEVS
PLOC     P:TOSECT SECT(1)
         DO       (Q(2)&X'100')=0
         BOUND    8
         DATA     %+1,50**16
         RES      50
STKADR   DATA     %-52
         ELSE
STKADR   DATA     AF(Q(6),2)
         FIN
CC%REG6  RES      1
LF(4)    EQU      %
REG4     RES      1
FPT%VLP  RES      1
SECT(1)  P:TOSECT PLOC
P:OPEN   DSECT    T1=2
CHTBL TEXTC './# ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789%*-%:#@!&^|\{}[]+'
TBL1     DATA     X'07010001',X'03000002',X'02000002',X'01000808'
TXSNS    DATA     'FT','LTDP'
TXDEV TEXT '//NOTYPRPPCRCPLPMEUCL1L2L3L4L5L6P1P2P3P4P5P6C1C2C3C4C5C6'
#DEVS    EQU      HA(%)-HA(TXDEV)-1
OPENDCB  STW,6    CC%REG6
         STW,4    REG4
         LW,6     *STKADR
         LW,2     *STKADR
         AH,2     *#X3
         AI,2     2
         STW,2    FPT%VLP
         LCH,2    *#X3
         LW,10    *#X3,2
         PSW,10   *STKADR
         BIR,2    %-2
         LI,1     4
         LW,11    ='    '
         LW,10    TBL1-1,1
         PSW,10   *STKADR
         AND,10   =X'FF'
         PSW,11   *STKADR
         BDR,10   %-1
         BDR,1    %-5
         LI,0     8
         LI,11    1
         LI,3     1**8
         LI,13    32
         BAL,15   SCN
         STB,8    *FPT%VLP
         LW,14    *FPT%VLP
         SLS,14   8
         LH,14    14
         LC       CC%REG6
         BCS,2    %3
         BCS,4    %6
         BCR,15   %2
%1       LI,3     3                 DELIM = #
         CH,14    TXSNS,3
         BE       %+3
         BDR,3    %-2
         B        ERTRN
         LI,3     (15*4)**8+15*4-1
         LI,13    5
         AI,11    X'40'
         BAL,15   SCN               SCAN SN
         CI,14    X'F0000'+'FT'
         BNE      %5                B/NOT FT
         BAL,15   CHKEND
         B        %8
%5       BL       %+2
         AI,11    1
         LC       CC%REG6
         BCR,2    ERTRN             B/DELIM NOT /
%4       LI,3     1**8
         LI,13    32
         BAL,15   SCN
         STB,8    *FPT%VLP
         BCR,15   SETDEV
         BCR,4    ERTRN             B/DELIM NOT .
%6       LI,3     (9*4)**8+9*4-1
         LI,9     0
         LI,13    9
         AI,11    8
         BAL,15   SCN+1
         BCR,15   SETDEV
         BCR,4    ERTRN
         AI,8     0
         BNEZ     %+3
         STB,8    *FPT%VLP,3
         AI,11    -8
         LI,3     (12*4)**8+12*4-1
         LI,13    9
         AI,11    X'200'
         BAL,15   SCN
         LI,15    SETDEV
CHKEND   LC       CC%REG6
         BCR,15   *15
         B        ERTRN
%3       CI,14    X'F0000'+'DC'     DELIM WAS /
         BNE      ERTRN
         B        %4
%2       CI,8     2                 END OF FIELD, NO DELIMS
         BG       SETDEV            B/CAN'T BE DEVICE (> 2 CHARS)
         LI,3     #DEVS
         CH,14    TXDEV,3
         BE       %8
         BDR,3    %-2
         B        SETDEV
%8       AI,11    -1
         LI,0     X'FFFF'
         AND,0    14
         B        %9
SETDEV   SLS,0    8
         AI,0     X'18000'-1**8
%9       STS,11   2,6
         LW,3     -15+#X3,6
         INT,3    0,3
         STW,0    *6,3
         ANLZ,2   *CC%REG6
         BCR,8    RET
         LW,3     *STKADR
         SW,3     6
         LW,10    *6,3
         STW,10   *2,3
         BDR,3    %-2
RET      STW,6    FPT%VLP
         MTW,1    FPT%VLP
         MTW,1    CC%REG6
ERTRN    MTW,1    CC%REG6
         SW,4     REG4
         STW,4    REG4
         SW,6     *STKADR
         MSP,6    *STKADR
         LCI      0
         PLM,0    *STKADR
         LW,#1U1  REG4
         EXU      1,#X3
         B        *CC%REG6
SCN      LI,9     1                 L/MIN SIZE
         SCS,3    -8
         LI,8     0                 L/CUR SIZE
         LB,5     CHTBL             L/CHTBL LEN
         LB,10    0,4               L/CHAR
         CI,10    X'40'             C/BLANK
         BNE      I                 B/NOT BLANK
         AI,4     1
         BDR,12   %-4               BDR
         B        ERTRN             B/END; ALL BLNK FLD
I        LB,10    0,4               L/CHAR
         LW,2     5                 L/CHTBL LEN
         CB,10    CHTBL,2           C/W/LEGAL
         BE       %+3               B/ABOVE
         BDR,2    %-2               BDR
         B        J                 B/END
         AI,4     1                 INC IN PNTR
         AI,2     -4                -4 TO INDEX
         BGZ      K                 B/LEGAL CHAR
         BLZ      %+3               B/DELIM
         LI,5     4                 L/CHTBL LEN
         B        J-1               B/BLANK
         BDR,12   J+1               BDR
         B        ERTRN             B/END; BAD
K        BDR,13   %+2               BDR,OUTMAX CNT
         B        ERTRN             B/REAL ERROR (OVER-RUN)
         STB,10   *FPT%VLP,3        STORE CHAR
         AI,3     1                 INC OUT PNTR
         AI,8     1
         BDR,12   I                 BDR
J        LI,2     -4                L/DUMMY DELIM PNTR
         CW,8     9                 C/CUR AND MIN
         BL       ERTRN             B/LESS THAN MIN
         LB,3     3
         BEZ      %+4
         LB,10    *FPT%VLP,3
         AI,3     -1
         STB,10   *FPT%VLP,3
         LC       WA(=X'402010')+1,2
         STCF     CC%REG6
         B        *15
         USECT    PLOC
         CLOSE    CHKEND,ERTRN,CC%REG6,SCN,TBL1,RET,SETDEV,TXDEV,;
 TXSNS,%6,%1,%2,%3,%4,%5,%8,%9,#DEV,I,J,K,REG4,CHTBL,#DEVS
%FIN     SET      %
LF(2)    EQU      FPT%VLP
         PEND
         PAGE
         OPEN     BASE,BD,BH,CMPRS,D,DB,FCMPRS,HB,S,FLDESC           *X*
FCMPRS   SET      0
FLDESC   SET      0
         PAGE
*  CHANGE THE REGISTERS USED IN P:SYSTEM.
*        P:REG    R#X1,R#X2,R#X3,R#4,R#1,R#1U1
P:REG    CNAME
         PROC
LF       SET      %
         ERROR,3,NUM(AF)~=6    INOA
         GOTO,NUM(AF)~=6    %PEND
#X1      SET      AF(1)
#X2      SET      AF(2)
#X3      SET      AF(3)
#4       SET      AF(4)
#1       SET      AF(5)
#1U1     SET      AF(6)
         ERROR,3,#X1=0|#X3=0|#X1>7|#X3>7|(#1&1)=1|#1U1~=#1+1;
  |(#X3&1)=0|#X2=0|#X2>7    'P:SYSTEM:  IMPROPER REGISTER ASSIGNMENT'
         DISP     #X1**24+#X2**20+#X3**16+#4**12+#1**8+#1U1**4+1
%PEND    PEND
         PAGE
P:B      CNAME
         PROC
LF       EQU      %
I        DO       NUM(AF)
         B        AF(I,1)
         FIN
         PEND
         PAGE
P:IOCDW  CNAME
         PROC
         BOUND    8
P        SET      S:KEYS(2,*18,ORDER,BUF,CDA,SIZE,;
         24,DC,IZC,CC,ICE,HTE,IUE,SIL,SKIP)
LF       GEN,8,5,19,8,8,16    AF(P(3),2),0,P:S((P(2)&X'1000')>0,;
   DA(AF(P(5),2)),BA(AF(P(4),2))),P(2)&X'FF',,AF(P(6),2)
         PEND
         PAGE
P:PSD    CNAME
         PROC
         BOUND    8
P        SET      S:KEYS(2,*0,CC,IA,WK,RP,MA,EA,21,RES,FS,FZ,FN,;
                  (SLAVE,MASTER),MAP,DM,AM,CI,II,EI)
LF   GEN,((P(2)&X'400')>0)*64,4,1,7,3,17,2,2,1,3,1,1,6,8,4,4    ;
   ,AF(P(3),2),,P(2)**-3&X'7F',,AF(P(4),2),,AF(P(5),2),,P(2)&7,;
   (NUM(AF(P(7)))=1)+AF(P(7),2),,AF(P(8),2),,AF(P(6),2),
         PEND
         PAGE
P:RES    CNAME    (3,0,1,,2,,,,3),(0,2,1,,0,,,,-1)
         PROC
         BOUND    P:S(NAME(1,CF(2)),1,2,4,8)
LF       EQU      BASE
BASE     SET      P:S(NAME(1,CF(2)),BA(BASE),HA(BASE),;
         WA(BASE),DA(BASE))+AF**NAME(2,CF(2))
         PEND
         PAGE
P:DESC   CNAME    P:FLAG(FLDESC)
         DO       FLDESC
SIZE     EQU      1
BIN      EQU      1
BC       EQU      1
WA       EQU      2
HEX      EQU      2
BA       EQU      3
DEC      EQU      3
BTD      EQU      4
WD       EQU      5
TYPE     EQU      6
         FIN
         PROC
         DISP     %
         LIST     0
LF(1)    EQU      %
I        DO       NUM(AF)
         RES,1    AF(I,2,2)
AF(I,1,1) EQU     AF(I,2,1),WA(%),BA(%),BA(%)-BA(LF(1)),;
                  WA(%)-WA(LF(1)),SCOR(AF(I,3,1),BIN,HEX,DEC)
         DO       P:MAX(AF(I,1,2),1)
         DO       NUM(AF(I))<4
         RES,1    AF(I,2,1)
         ELSE
         DO       SCOR(AF(I,4),BLANK)*AF(I,2,1)
         DATA,1   X'40'
         ELSE
         DATA,AF(I,2,1)  AF(I,4)
         FIN
         FIN
         FIN
         FIN
LF(2)    EQU      BA(%)-BA(LF(1))
         LIST     1
         PEND
         PAGE
P:COMFLD CNAME    X'60'
P:MOVFLD CNAME    X'61'
         PROC
LF       EQU      %
I        DO       NUM(AF)
K        SET      AF(I)
J        SET      P:S(TCOR(K(2),S:LIST),BA(K(2)),K(2,3))
         LW,#1U1  =P:S(TCOR(K(2),S:LIST),K(1,1),K(2,1))**24+J
         GEN,8,4,20   NAME,#1U1,P:S(TCOR(K(1),S:LIST),BA(K(1)),K(1,3))-J
         FIN
         PEND
         PAGE
P:MOV    CNAME
         PROC
LF       EQU      %
I        DO       NUM(AF)
S        SET      P:S(TCOR(AF(I,1),S:LIST),(4,P:S(TCOR(AF(I,1),1),;
   WA(AF(I,1)),AF(I,1)/4),BA(AF(I,1)),0,0,0),AF(I,1))
D        SET      P:S(TCOR(AF(I,2),S:LIST),(4,P:S(TCOR(AF(I,2),1),;
   WA(AF(I,2)),AF(I,2)/4),BA(AF(I,2)),0,0,0),AF(I,2))
         GOTO,S(6)**2+D(6) M,M,M,M,M,BH,BD,M,HB,M,M,M,DB,M,M
M        MOVE     (S(1),S(2),S(3)),(D(1),D(2),D(3)),P:MIN(D(1),S(1))
         GOTO     %FIN
BH       BOUND    1
         P:BINHEX (BIN,S(3)),(BTD,D(3)),(SIZE,D(1)),(SUB)
         GOTO     %FIN
BD       LOAD     #1U1,(S(1),S(2),S(3)),S(1)
         P:BINDEC (BIN,#1U1),(BTD,D(3)),(SIZE,D(1))
         GOTO     %FIN
HB       P:HEXBIN (BIN,#1U1),(BTD,S(3)),(SIZE,S(1))
         STORE    #1U1,(D(1),D(2),D(3)),D(1)
         GOTO     %FIN
DB       P:DECBIN (BIN,#1U1),(BTD,S(3)),(SIZE,S(1))
         STORE    #1U1,(D(1),D(2),D(3)),D(1)
%FIN     FIN
         PEND
         PAGE
P:SIZE   FNAME
         PROC
K        SET      0
J        SET      %
I        DO       NUM(AF)
         USECT    AF(I)
K        SET      K+(ABSVAL(BA(%))+7)/8*2
         FIN
         ORG      J
         PEND     K
         PAGE
*  TAB TO GIVEN DISP IN BUFFER, GENERATE TEXT.
P:TAB    CNAME
         PROC
J        SET      %
         LIST     0
I        DO       NUM(AF)
K        SET      AF(I,1)
  ORG,1 BA(LF(1))+P:S(TCOR(K,S:LIST),(K),K(4))-P:S(SCOR(AF(I,3),RJ,LJ),;
  SCOR(CF(2),RJ),1,0)*(S:NUMC(AF(I,2))-1-P:S(TCOR(K,S:LIST),0,K(1)-1))
         DATA,1   S:UT(AF(I,2))
         FIN
         ORG,4    J
         LIST     1
         PEND
         PAGE
*  COMPRESS A TEXTC BUFFER, REPLACING MULTIPLE BLANKS WITH SINGLE BLANKS.
P:COMPRESS    CNAME
         PROC
P        SET      S:KEYS(2,*30,BUF)
LF(1)    P:LI,#1U1 WA(AF(P(3),2))
         BAL,#X1  CMPRS
         GOTO,P:FLAG(FCMPRS)    %PEND
PLOC     P:TOSECT SECT(T1)
         LOCAL    I,J
CMPRS    LB,#1    *#1U1
         LI,#X2   1
         LI,#X3   0
I        LB,#4    *#1U1,#X2
         AI,#X2   1
         AI,#X3   1
         STB,#4   *#1U1,#X3
         CI,#4    X'40'
         BE       J
         BDR,#1   I
         B        J+1
         CB,#4    *#1U1,#X2
         BNE      I
         AI,#X2   1
J        BDR,#1   %-3
         STB,#X3  *#1U1
         B        0,#X1
SECT(T1) P:TOSECT PLOC
%PEND    PEND
         CLOSE    BASE,BD,BH,CMPRS,D,DB,FCMPRS,HB,S,FLDESC           *X*
   ERROR,* TBLK,AST,AST
   ERROR,* TBLK,'*  P:SYSTEM:'
   ERROR,* TBLK,'*  LAST UPDATE:       01 NOV 77'
   ERROR,* TBLK,'*  REGISTERS USED:    1, 2, 3, 11, 12, AND 13'
   ERROR,* TBLK,'*  CONTROL SECTIONS:  ',P:BH(CS(SECT(T0))),;
   ' (PT 0) AND ',P:BH(CS(SECT(T1))),' (PT 1)'
   ERROR,* TBLK,AST,AST
         CLOSE    PLOC,CHEX,FCHEX,INOA,SEBN,%PEND,IAF,LBL,;
   T0,T1,SECT,P,UK,%FIN,#X1,#X3,#4,#1,#1U1,#X2,RP,;
   FLIMF09,LIMF09,CP,DDEF,%FIN1,%FIN2,%FIN3,I,J,K,L,M,IIAF,;
   FLIMC16,LIMC16,SHXBN,FHEXBIN,IFE,FEBCBIN,;
   TCBTD,TX,TSZ,Q,N,STORE,LOAD,MOVE,#LT,LT,LTBAD,VT,#4TMP,;
   FSBNHX,SBNHX,#BA,#WA,FLPTBL,LPTBL,TBLK,AST,FERRMSG,;
   CLSDO,CLSXX,KBF,OPNXX,RBF,RDXX,R10TMP,R8TMP,TXBDER,TXDCB,WRTDO,;
   FLOPEN,FPT%VLP,FSCAN,FTBLSRCH,OPENDCB,OUTBUFF,SCAN,SCN,;
   STKADR,SPDPNTR,TBLSRCH,%DEV,SKPCHR,SB,FLFNDVLP,FNDVLP,;
   BABUF,BATBL,DELIMS
         END
