*M*      TPPROCS CONTAINS TRANSACTION PROCESSING PROCS
         SYSTEM   BPM
         OPEN     PLOC,ULOC,LISTLOC,UP,PC,INOA,IBPRA
         OPEN     PF,P
         OPEN     S:S,G,BAV
         DISP     X'C01'
UP       EQU      'UNRECOGNIZED KEY'
INOA     EQU      'IMPROPER NUMBER OF ARGUMENT FIELDS'
PC       EQU      'PARAMETER CONFLICT'
IBPRA    EQU      'ILLEGAL BUF ADDRESS'
ULOC     SET      %
         CSECT
PLOC     SET      %
         CSECT    1
LISTLOC  SET      %
         ORG      ULOC
         OPEN     USET
USET     CNAME
         PROC
LF       SET      %
         ORG      AF
         PEND
G        CNAME
         PROC
         BOUND    4
LF       GEN,1,7,4,3,17 AFA(1),CF(2),CF(3),AF(2),AF(1)
         PEND
S:S      FNAME
         PROC
         PEND     AF(AF(1)+2)
BAV      CNAME                      TEST BUFFER ADDRESS VALIDITY
         PROC
         ERROR,3,(CF(2)|AFA=0)&ABSVAL(WA(AF))<16;
                 &TCOR(AF,S:INT,S:AAD)>0&AF]=0 IBPRA
         PEND
         PAGE
         OPEN     V,I,P
M:QUEUE  CNAME
         PROC
         BOUND    4
PF       SET      SCOR(CF(2),E,L)
LF(1)    DO1      PF=0|PF=1
 GEN,1,7,4,3,17 S:S(PF=1,(,4,7,,PLOC),(AFA,4,7,AF(2),AF(1)))
         DO1      PF=0
ULOC     USET     PLOC
         DO       PF=0|PF=2
V        SET      SCOR(AF(2),UNLOCK,DEFINELIST,PUT,GET,STATS,PURGE,LOCK)
         ERROR,3,V=0|NUM(AF(2))>1  UP
         GOTO,V   V,DEFINELIST,PUT,GET,STATS,PURGE,LOCK
V        SET      1
P  SET  S:KEYS(1,0,(#,UNLOCK),*0,ECB,QPAGES,KEYMAX,QSAT,24,RECOVER,;
                  (NEW,OLD),BACKUP,WAIT)
         GOTO     FIN
DEFINELIST  CLOSE
P  SET  S:KEYS(1,0,(#,DEFINELIST),*0,ECB,*LSIZE,27,WAIT)
         GOTO     FIN
PUT      CLOSE
P  SET  S:KEYS(1,0,(#,PUT),*0,ECB,*LSIZE,26,(HIGH,LOW),WAIT)
         GOTO     FIN
GET      CLOSE
P  SET  S:KEYS(1,0,(#,GET),*0,ECB,INDEX,*BUF,*BSIZE,27,WAIT)
         GOTO     FIN
STATS    CLOSE
P  SET  S:KEYS(1,0,(#,STATS),*0,ECB,LSIZE,BUF,BSIZE,26,COUNT,WAIT)
         GOTO     FIN
PURGE    CLOSE
P  SET  S:KEYS(1,0,(#,PURGE),*0,ECB,27,WAIT)
         GOTO     FIN
LOCK     CLOSE
P  SET  S:KEYS(1,0,(#,LOCK),*0,ECB,23,PAUSE,27,WAIT)
FIN      CLOSE
LF(2)    GEN,1,7,7,17,32 AFA(1),V+5,0,AF(1),P(2)
I        DO       NUM(P)-2
         G        AF(P(I+2),2)
         DO1      SCOR(AF(P(I+2),1),BUF)
         BAV      AF(P(I+2),2)
         FIN
         FIN
         DO1      PF=0
PLOC     USET     ULOC
         PEND
         CLOSE    V,I,P
         PAGE
*
****************
*
M:GETLINE CNAME   X'00',7
M:RLSLINE CNAME   X'01',7
M:BUFSTAT CNAME   X'02',7
M:MDFLST CNAME    X'04',7
         PROC
         LOCAL    I,J,K,L,ADR,CONT
         BOUND    4
PF       SET      SCOR(CF(2),E,L)
LF(1)    EQU      %
         DO       PF=0|PF=1
         GEN,1,7,4,3,17 S:S(PF=1,;
                        (0,4,NAME(2),0,PLOC),;
                        (AFA,4,NAME(2),AF(2),AF(1)))
         FIN
         DO1      PF=0
ULOC     USET     PLOC
         DO       PF=0|PF=2
J        SET      NUM(AF)
K        SET      5&NAME(1)
         ERROR,3,(J=0)|((J~=1)&(K=0))|((J>2)&(K~=4)) INOA
LF(2)    G,NAME(1) AF(1)
         DO       NAME(1)=4
P        SET      S:KEYS(3,*1,REPL,*23,HALT,CLS,OPN,PSL,;
                              SEL,POL,INDX,EXCL,INCL)
K        SET      S:S(P(2)&7,0,0,0,3,0,5,6,7),;
                  S:S((P(2)**-3)&7,0,0,0,3,0,5,6,7),;
                  S:S((P(2)**-6)&3,0,0,0,3)
J        DO       3
         ERROR,3,K(J) PC
         FIN
         ERROR,3,((P(2)&X'40000007')~=0)&;
                 ((P(2)&X'00000078')=0)   'POL,PSL OR SEL REQUIRED'
I        SET      1
L        WHILE    I
K        SET      9+L
J        SET      NUM(AF(P(K),1))
         GOTO,(L<3)&(J=0)     CONT
I        SET      0
CONT     SET      %
         FIN
         DO       J=1
ADR      SET      NUM(AF(P(K),2))
         DO1      ADR
P(2)     SET      P(2)|X'80000000'
         FIN
         GEN,32   P(2)
         DO       J=1
J        SET      SCOR(INDX,AF(P(K),1))
         ERROR,3,(J=1)&(ADR=0) 'INDX OPTION REQUIRES ADDRESS'
         DO1      ADR|(J=1)
         GEN,1,31 AFA(P(K),2),AF(P(K),2)
         FIN
         DO       NUM(AF(P(3),1))
         GEN,1,31 AFA(P(3),2),AF(P(3),2)
         GEN,1,31 AFA(P(3),3),AF(P(3),3)
         ERROR,3,(AF(P(3),2)=0)|(AF(P(3),3)=0) 'REPL NEEDS 2 ADDRESSES'
         FIN
K        SET      0
         FIN
         DO       K&(J-1)
         DO       NAME(1)=1
P        SET      SCOR(AF(2,2),SLAVE,MASTER,EITHER)
         ERROR,3,(SCOR(AF(2,1),TYPE)=0)|P=0 UP
         DO1      P=3
P        SET      -1
         ELSE
P        SET      SCOR(AF(2,1),READ,WRITE)
         ERROR,3,P=0|AF(2,2)~=0 UP
         DO1      P=2
P        SET      -1
         FIN
         DATA     P
         ELSE
         DO1      K
         DATA     0
         FIN
         FIN
         DO1      PF=0
PLOC     USET     ULOC
         PEND
         PAGE
*
********************
*
M:LIST   CNAME
         PROC
         LOCAL    OPNCLS,NEXTX,#KEYWDS,KEYWD,SKIPIT,#SLOTS,BGNRING,;
                  FLINK,DEV,I,J,K,L,M,N,LL,NN,CONT1,CONT2,CURKEY,;
                  MATCH,PSLHIT,POLX,SELX,PFLG,SFLG,START,END,GENERATE
         BOUND    4
ULOC     USET     LISTLOC
         ERROR,3,NUM(LF)=0 'REQUIRED LIST LABEL MISSING'
OPNCLS   SET      -1                INITIALIZE OPN/CLS FLAG
BGNRING  SET      0,0                INITIALIZE BEGIN LIST POINTERS
NEXTX    SET      1                 INITIALIZE LIST ELEMENT PNTR
#KEYWDS  SET      NUM(AF)
         ERROR,3,#KEYWDS=0 INOA
LF,START SET      %                 MARK START OF LIST
         ORG      %+2               SKIP OVER HEADER FOR NOW
*
*  BEGIN LEFT TO RIGHT SCAN OF PROCEDURE REFERENCE LINE AND
*  BUILD ELEMENT ENTRIES ONE AT AT TIME AS YOU GO.
*
I        DO       #KEYWDS
KEYWD    SET      SCOR(AF(I,1),POL,SEL,PSL,OPN,CLS)
         ERROR,3,KEYWD=0 UP
         DO1      KEYWD>3           IF >, THEN OPN/CLS HIT
OPNCLS   SET      KEYWD-4           SO SET OPN/CLS FLAG ACCORDINGLY
         GOTO,(KEYWD>3)|(KEYWD=0) SKIPIT  IF TRUE, EXIT & TRY NEXT ONE
#SLOTS   SET      NUM(AF(I))-1      #PARAMETERS W/ THIS KEYWORD
         ERROR,3,#SLOTS=0 INOA
         GOTO,#SLOTS=0              SKIPIT  IF TRUE, EXIT & GO ON
         PAGE
*
*  BEGIN ANALYZING THE ELEMENTS (PARAMETERS) ASSOCIATED WITH
*  THE CURRENT KEYWORD VALUE.
*
J        DO       #SLOTS
NEXTX    SET      NEXTX+1           BUMP CURRENT ELEMENT PNTR
N        SET      NEXTX             MARK CURRENT ELEMENT PNTR
M        SET      I                 MARK CURRENT KEYWORD COUNT
DEV      SET      0                 ASSUME CURRENT PARAMETER=DUM
FLINK    SET      S:S(KEYWD-1,(-1,0),(0,-1),(-1,-1))  SET FOR-
*                                   WARD LINKS ACCORDINGLY
         GOTO,SCOR(AF(I,J+1),DUM) GENERATE
DEV      SET      AF(I,J+1)         O.K., SO IT'S NOT = DUM
NN       SET      1                 INITIALIZE REMAINING ELEMENTS-
*                                   THIS-GROUP POINTER
         DO1      ((KEYWD&1)=1)&(BGNRING(1)=0)
BGNRING(1) SET    N-1               ESTABLISH 1ST POL ENTRY PNTR
         DO1      ((KEYWD&2)=2)&(BGNRING(2)=0)
BGNRING(2) SET    N-1               ESTABLISH 1ST SEL ENTRY PNTR
K        SET      #SLOTS-J          LOOK FOR NEXT NON-DUM THIS GROUP
         WHILE    K
FLINK    SET      S:S(KEYWD-1,(N,0),(0,N),(N,N)) ASSUME = NON-DUM
         GOTO,SCOR(AF(I,J+1+NN),DUM) CONT1
K        SET      0                 NON-DUM HIT; TURN OFF WHILE LOOP
         GOTO,1   CONT2
CONT1    SET      %
NN       SET      NN+1              BUMP REMAINING ELMNTS-THIS-GRP PNTR
N        SET      N+1               BUMP LIST ELEMENT PNTR
CONT2    SET      %
K        SET      K-1               DECREMENT LOOP COUNT
*
         FIN                        *****
*
         GOTO,K=-1          GENERATE
*
*  HAVEN'T FOUND A CANDIDATE YET; EITHER J=#SLOTS OR EVERYTHING
*  AFTER J IN THIS GROUP IS = DUM.
*
CURKEY   SET      KEYWD             MARK CURRENT KEYWORD INDICATOR
PFLG,SFLG SET     1         INITIALIZE LOOK-AHEAD POL-SEL HIT FLAGS
L        SET      #KEYWDS-I         SO LOOK FOR NEXT "LIKE"
         WHILE    L                 KEYWORD OR PSL KEYWORD
M        SET      M+1               BUMP LOOK-AHEAD KEYWORD COUNTER
MATCH    SET      (SCOR(AF(M,1),POL,SEL,PSL)=CURKEY)|(CURKEY=3)
PSLHIT   SET      SCOR(AF(M,1),PSL)      TO CK FOR A PSL ENCOUNTER
         GOTO,(MATCH=0)&(PSLHIT=0) CONT1 MOVE ON TO NEXT KEYWORD
*                                        IF NO LUCK W/THIS ONE
         DO1      PFLG
POLX     SET      N                 MARK LOOK-AHEAD POL ELMNT PNTR
         DO1      SFLG
SELX     SET      N                 MARK LOOK-AHEAD SEL ELMNT PNTR
LL       SET      1                 INITIALIZE REMAINING ELEMENTS-
*                                   THIS-GROUP POINTER
*                                   WE MAY FIND ONLY DUM ENTRIES
K        SET      NUM(AF(M))-1      LOOK FOR NON-DUM IN THIS
         WHILE    K                 LOOK-AHEAD GROUP
         GOTO,SCOR(AF(M,LL+1),DUM) CONT2 CONTINUE SEARCH IF = DUM
K        SET      1                 TURN OFF K WHILE LOOP
         DO       (CURKEY=3)&(PSLHIT=0)
CURKEY   SET      SCOR(AF(M,1),SEL,POL) SET SO NEXT TIME THRU
*                                   WE'RE LOOKING FOR OPPOSITE TYPE
PFLG     SET      PFLG||SCOR(AF(M,1),POL)   SET LOOK-AHEAD POL-SEL
SFLG     SET      SFLG||PFLG                FLAGS ACCORDINGLY
         ELSE
L        SET      0                 TURN OFF L WHILE LOOP AND
FLINK    SET      POLX,SELX         SET UP FORWARD PNTRS
         DO1      (PFLG&SFLG)=1     ONE PNTR=0 IF KEYWD NOT = PSL.
FLINK    SET      S:S(CURKEY-1,(POLX,0),(0,SELX),(POLX,SELX))
*
         FIN                        *****
*
CONT2    SET      %
POLX     SET      POLX+PFLG         BUMP SUB-LOOK-AHEAD POL ELMNT PTR
SELX     SET      SELX+SFLG         BUMP SUB-LOOK-AHEAD SEL ELMNT PTR
K        SET      K-1               DECREMENT K LOOP CONTROL
LL       SET      LL+1              BUMP REMAINING ELMNTS-THIS-GRP PNTR
*
         FIN                        *****
*
*  ALL DUMS IN THIS LOOK-AHEAD GROUP
*
CONT1    SET      %
N        SET      N+NUM(AF(M))-1    BUMP LOOK-AHEAD ELEMENT PNTR
L        SET      L-1               DECREMENT L LOOP CONTROL
*                                   PAST THIS UNSATISFYING GROUP
         FIN                        *****
*
         GOTO,L=-1       GENERATE
*
*  AT THIS POINT THE WHOLE REFERENCE LINE HAS BEEN SCANNED AND
*  WE STILL HAVEN'T FOUND BOTH NECESSARY FORWARD LINKS
*
         DO1      PFLG&SFLG
POLX,SELX SET     0                 REQUIRED IF KEYWD<3
FLINK    SET      S:S(CURKEY-1,(BGNRING(1),SELX),(POLX,BGNRING(2)),;
                               (BGNRING))
GENERATE SET      %
         GEN,8,8,16 FLINK,DEV       GENERATE A LIST ENTRY
*
         FIN                        *****
*
SKIPIT   SET      %
*
         FIN                        *****
*
         ERROR,3,OPNCLS<0 'OPN/CLS OPTION NOT SPECIFIED'
         DO1      OPNCLS<0          DEFAULT TO CLS IN THIS CASE
OPNCLS   SET      1
END      SET      %
         ORG      START             GO BACK AND DO HEADER
         GEN,16,16 OPNCLS,END-(START+2)  FLAGS & LIST LENGTH
         GEN,16,8,8 0,BGNRING       GENERATE START OF RING INDICES
         ORG      END               GO BACK TO BOTTOM OF LIST
LISTLOC  USET     ULOC
         PEND
         CLOSE    PLOC,ULOC,LISTLOC,UP,PC,INOA,IBPRA
         CLOSE    PF,P
         CLOSE    S:S,G,BAV
         CLOSE    USET
         END
