*
* SYSTEM DATADEF:
*
* SEND YOUR ENQUIRIES AND SUGGESTIONS TO NED EVANS.  ALSO
* SEND YOUR NAME, ADDRESS, AND DESCRIPTION OF YOUR SYSTEM
* FOR THE DIRECTORY OF USERS.  THANKS.
* DON'T TRY TO UNDERSTAND THESE PROCS WITHOUT FIRST UNDERSTANDING
* THE WRITEUP (#705673-11, SOFTWARE LIBRARY).
*
*DISP X'0DDEFB00' VERSION B00 (FASTER :ITEM; EO WITH BI>0; *AD:X; LB&LH)
*DISP X'0DDEFB01' VERSION B01 (FIXED :PUT FOR AIQEOVAL FOR ENV FOR X4S).
*DISP X'0DDEFC00' VERSION: PASS SW.IN :GET/:PUT; NEW= :TXXX,:JXXX,:COPY,
* :ST,:BIA,:ISH,:STV,:PSTV,:LWC,:AWC,:LAM,:DEPZ,:DEP; NEW 'TEXT' 7 CHAR.
* STATUS NAMES UNIQUE TO DEFINITION; ITEMLIST NOW NOT WRAPPED.
*DISP X'0DDEFC01' VERSION: FASTER & SMALLER PASS SWITCHING, AND
* THANKS TO JOAN BELL FOR A BUG FIX, INCORPORATED NOW, TO CORRECT :PUT
* FAMILY IN THE RARE X4 CASE--GENERATED CODE NOW IS ONE INSTRUCTION MORE
* BUT WORKS PERFECTLY IN ALL RUN-TIME CASES.
 DISP X'0DDEFC02'  VERSION:
 DISP X'042272'
*
* CAVEATS: 1)  CHANGED DEF ITEMLIST STRUCTURE--NOW WITHOUT SURROUNDING
*          PARENTHESIS, EIGHT ELEMENTS INSTEAD OF SEVEN, THE 8TH BEING
*          EITHER ZERO OR A SUBLIST OF STATUS NAMES AND VALUES
*
*          2)  'TEXT' STATUS NAME MODE NOW REQUIRES SWITCH BEFORE SYSTEM
*          DATADEF, AS FOLLOWS;  :ST%TEXT%SWITCH SET 1
*
*          3)  **** BE WARNED **** WITH THIS SYSTEM, AS WITH ANY NEW
*          SYSTEM, REGRESSION TESTING SHOULD BE PERFORMED IN THE USER'S
*          OWN ENVIRONMENT BEFORE DISCARDING THE PREVIOUS SYSTEM.
         PAGE
*
 OPEN AI,CI,LI,MI,SH,AW,CW,LW,STW,LCW,CS,XW,STS,OR,AND,LH,STH,BCR,BCS
 OPEN LBY,STB,ANLZ,MBS
* OP CODES FOR GENS THAT COMPOSE INSTRUCTIONS
AI       EQU      32     X'20'
CI       EQU      33     X'21'
LI       EQU      34     X'22'
MI       EQU      35     X'23'
SH       EQU      37     X'25'
AW       EQU      48     X'30'
CW       EQU      49     X'31'
LW       EQU      50     X'32'
STW      EQU      53     X'35'
LCW      EQU      58     X'3A'
ANLZ     EQU      68     X'44'
CS       EQU      69     X'45'
XW       EQU      70     X'46'
STS      EQU      71     X'47'
OR       EQU      73     X'49'
AND      EQU      75     X'4B'
LH       EQU      82     X'52'
STH      EQU      85     X'55'
MBS      EQU      97     X'61'
BCR      EQU      104    X'68'
BCS      EQU      105    X'69'
LBY      EQU      114    X'72'
STB      EQU      117    X'75'
*
 OPEN ARTH,CIR,DBL,SHM,WL,#BYTESPERWL,WM,HL,BL
* GENERAL MNEMONICS
ARTH EQU 1024     --ARITHMETIC SHIFT BIT
CIR EQU 512       --CIRCULAR SHIFT BIT
DBL EQU 256       --DOUBLEWORD SHIFT BIT
SHM EQU 127       --SHIFT INCREMENT MASK
WL EQU 32         --WORD LENGTH OF THE MACHINE
#BYTESPERWL EQU 4 --# OF BYTES/WORD SIGMA5,6,7,8,9
WM EQU WL-1       --WORD LENGTH MINUS ONE
HL EQU WL/2       --HALFWORD LENGTH
BL EQU WL/#BYTESPERWL --BYTE LENGTH
*
 OPEN NIE,SO,SP,SPI,SP2I,SP4
*
NIE      EQU      8     # ELEMENTS PER ITEMLIST (FORMED BY :ITEM PROC)
SO       EQU      1,7,4,3,17
SP       EQU      8,4,3,17
SPI      EQU      8,4,20
SP2I     EQU      SP,SPI
SP4      EQU      SP,SP,SP,SP
*
         OPEN     ERRMSSG
* THESE ERROR MESSAGES ARE PRINTED FROM PROCS FINDING ERRORS
QMA EQU 'DATADEF ILLEGAL ARGUMENT'
QMB EQU 'DATADEF (BI) ILLEGAL VALUE--DEFAULT = 0'
QMC EQU 'DATADEF ILLEGAL ITEM LENGTH'
QMD EQU 'DATADEF REQUIRES EVEN NUMBERED CF(2)'
QME EQU 'DATADEF REQUIRES REPEATABLE ITEMS (BI>0) DEFINED WITH LB<BI'
QMF EQU 'DATADEF REQUIRES A SPARE INDEX--DEFAULT FOR CF(3)'
QMG EQU 'DATADEF DETECTS CONFLICT OF *ITEMLIST(#AD) WITH REGISTER'
QMH EQU 'DATADEF ILLEGAL REGISTER (CF(2) BAD; CF(3) OR AF(2) NEQ INDEX)'
QMI EQU 'DATADEF ILLEGAL SUBSCRIPT USE'
QMJ EQU 'DATADEF ILLEGAL AF(2) VALUE'
QMK EQU 'DATADEF ITEM REQUIRES ODD-NUMBERED WORKING REGISTER'
QML EQU 'DATADEF ITEM REQUIRES CF(2)+1 AS A WORKING REGISTER'
QMM EQU 'DATADEF ITEM REQUIRES AN INDEX FOR WORKING REGISTER'
QMN EQU 'DATADEF REQUIRES 3 ARGUMENT FIELDS FOR THIS COMMAND'
QMO EQU 'DATADEF WARNING: REGISTER USAGE OVERLAP'
ERRMSSG FNAME 0
         PROC
         ERROR,0,1||AF(2) #(AF(1),,EM1,EM2,EM3,EM4,EM5,EM6,EM7,EM8,EM9)
         PEND
*
 OPEN #FB,#LB,#AD,#BI,#EO,#SF,#AL,#ST,#NENT,ITEMLIST
* THESE ARE USED TO SUBSCRIPT THE ITEMLIST TO OBTAIN ITS ELEMENTS
#FB      EQU      1
#LB      EQU      2
#AD      EQU      3,1
#BI      EQU      4
#EO      EQU      5
#SF      EQU      6
#AL      EQU      7
#ST      EQU      8
#NENT    SET      #ST,1
         SPACE 3
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN    #        THIS OPEN COVERS ALL USES OF THE SELECT FUNCTION.
* THIS IS THE SELECT PROC:  ITS 1ST EXPR. IS EVALUATED TO CHOOSE
*    WHICH OF THE FOLLOWING EXPR. TO EVALUATE TO  RETURN ITS RESULT
* CALL:  #(CHOOSER,CH(0),CH(1),...CH(N))
#        FNAME 0
         PROC
         PEND     AF(AF(1)+2)
* RETURN:  CH(I) EVALUATED
         SPACE 3
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN    PASS      THIS OPEN COVERS ALL USES OF PASS
PASS SET S:UFV(PASS)+1
* THE SWITCH IS USED BY SOME OF THE PROCS TO GAIN ASSEMBLY SPEED.
*
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
:INULL   CNAME 0  LF  :INULL  ITEM1,ITEM2,...ITEMN
:INULL   FNAME 0  LF  SET     :INULL(ITEM1,ITEM2,...ITEMN)
         PROC
AF       SET
         PEND
         SPACE 3
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* CALL: :K(CONSTANT EXPRESSION)   --WHERE ITEMLIST HAS PREVIOUSLY BEEN
*       SET TO THE ITEM DEFINITION LIST
*
:K       FNAME
         PROC
         PEND     (AF*ITEMLIST(#BI))**-5,AF*ITEMLIST(#BI)&31
*
* RETURN: A LIST OF TWO--(1) THE BIAS (IN WHOLE WORDS) FROM THE ZEROTH
*         TO THIS ITEM ENTRY. (2) THE INTRA-WORD SHIFT (IN BITS, IF ANY)
*         NECESSARY TO LEFT-SHIFT FROM THIS ENTRY TO THE POSITION OF
*         THE ZEROTH ENTRY.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
         OPEN     FLAGS,SDFLG,TXXXFLG,KIFLG,COPYFLG
FLAGS    FNAME    0
         PROC
AF(1)    SET      AF(2)
         PEND
SDFLG,TXXXFLG,KIFLG,COPYFLG SET 0
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN    M,PV,S,LPV,N4%A
* CALL: :TXX,EVENREG (*ITEM,:K(CONSTANT)),VALUE,(*BRANCHING%LOCATION,X)
*       :TAXX,ANYREG (*ITEM,:K(CONSTANT)),MASKING%VALUE,(*LOCATION,INDX)
*
:TE      CNAME    BCR,3+FLAGS(TXXXFLG,1)
:TNE     CNAME    BCS,3+FLAGS(TXXXFLG,1)
:TG      CNAME    BCS,2+FLAGS(TXXXFLG,1)
:TGE     CNAME    BCR,1+FLAGS(TXXXFLG,1)
:TL      CNAME    BCS,1+FLAGS(TXXXFLG,1)
:TLE     CNAME    BCR,2+FLAGS(TXXXFLG,1)
:TAZ     CNAME    BCR,4+FLAGS(TXXXFLG,1)
:TANZ    CNAME    BCS,4+FLAGS(TXXXFLG,1)
 DO PASS=1
 PROC
LF(1)    ::LWC,CF(2),CF(3) AF(1)
M,ITEMLIST SET    AF(1,1)
S        SET      AF(1,2)
N4%A     SET      NAME(2)=4|M(#AL)
 GOTO,M(#AL)=0|NAME(2)=4 PV
         ::XTR,CF(2) M
         ::POSC,CF(2) M(#FB)+S(2)
         ::POSA,CF(2) -(M(#FB)+S(2))
PV       SET      AF(2)
PV       SET      PV**(WM-M(#LB)-S(2))
LPV      SET      #(PV<1**19&N4%A,L(PV),PV)
M        SET      (1**(M(#LB)-M(#FB)+1)-1)**(WM-M(#LB)-S(2))
M        SET      #(M<1**19|N4%A,(LW,CF(2)|1,L(M)),(LI,CF(2)|1,M))
LF(2)    RES       2+(N4%A=0)
 PEND
 ELSE
 PROC
LF(1)    ::LWC,CF(2),CF(3) AF(1)
M,ITEMLIST SET    AF(1,1)
S        SET      AF(1,2)
N4%A     SET      NAME(2)=4|M(#AL)
 GOTO,M(#AL)=0|NAME(2)=4 PV
         ::XTR,CF(2) M
         ::POSC,CF(2) M(#FB)+S(2)
         ::POSA,CF(2) -(M(#FB)+S(2))
PV       SET      AF(2)
PV       SET      PV**(WM-M(#LB)-S(2))
LPV      SET      #(PV<1**19&N4%A,L(PV),PV)
M        SET      (1**(M(#LB)-M(#FB)+1)-1)**(WM-M(#LB)-S(2))
M        SET      #(M<1**19|N4%A,(LW,CF(2)|1,L(M)),(LI,CF(2)|1,M))
E ERROR,0,NUM(ITEMLIST)~=NIE QMA
 ERROR,0,NUM(CF)<2 'DATADEF DETECTS MISSING CF'
 ERROR,0,N4%A=0&CF(2)&1 QMD
LF(2)    GEN,#(N4%A,SPI)      M
         GEN,#(N4%A,,SPI)     #(PV<1**19,CW,CI),CF(2),LPV
         GEN,#(N4%A,SP)       CS,CF(2),,LPV
         GEN,SO   AFA(3)|AFA(3,1),NAME(1),NAME(2),AF(3,2),AF(3,1)
%PEND    PEND
 FIN
*
* RETURN:  FOR  :TXX  &  LOGICAL           FOR  :TAXX  &  ARITHMETIC
*          ---------------------           -------------------------
*         :LWC,CF(2)  AF(1)               :LWC,CF(2) AF(1)
*                                          *** IF ARITHMETIC ***
*                                               :XTR,CF(2) AF(1)
*                                               :POSC,CF(2) :LJ(AF(1))
*                                               :POSA,CF(2) :LIJ(AF(1))
*
*          LW/LI,CF(2)|1  L(:M( ))/:M( )
*                                          CW/CI,CF(2) L(:PV( ))/:PV( )
*          CS,CF(2)   L(:PV( ))
*          BCX,NAME(2) *AF(3),INDEX        BCX,NAME(2) *AF(3),INDEX
 CLOSE   M,PV,S,LPV,N4%A
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN N,E,D,S,V,P,ADASINDX,CX,%P2,AAD,LNG,LV,OP#
* CALL: :LWC,ANYREG,INDEX *ITEM,:K(CONSTANT) ...NO VARIABLE SUBSCRIPT...
*       :AWC,ANYREG,INDEX *ITEM,:K(CONSTANT)          "
*       :LAM,ANYREG,INDEX *ITEM,:K(CONSTANT)          "
*       :DEPZ,EVENREG,INDEX *ITEM,:K(CONSTANT)        "
*       :DEP,EVENREG,INDEX *ITEM,:K(CONSTANT)         "
* WHERE THE MAXIMUM CONDITIONS ARE SHOWN, ALTHOUGH NOT NECESSARY. THE
* INDEX IN CF(3), FOR EXAMPLE, IS NEEDED ONLY FOR FETCHING ITEMS THAT
* ARE REACHED VIA INDIRECT #AD POINTER THAT IS NOT AN INDEX REGISTER
* WHEN #EO IS NON-ZERO...AND THE USE OF BOTH INDIRECT (*) AND CONSTANT
* SUBSCRIPTING (:K FUNCTION) IS OPTIONALLY ALLOWED.
*
 DO       TXXXFLG
::LWC    CNAME    1
 FIN
:LWC     CNAME    1  'LOAD WORD CONTAINING' THE ITEM FROM MEMORY
:AWC     CNAME    2  'AND WORD CONTAINING' THE ITEM FROM MEMORY INTO
*                    CF(2), WHICH IS ASSUMED TO BE PRELOADED WITH A MASK..
:LAM     CNAME    3  'LOAD AND MASK' THE ITEM FROM MEMORY INTO ITS OWN
*                    MASK IN CF(2), WHICH IS NOT PRESUMED PRELOADED.
:DEPZ    CNAME    4  'DEPOSIT ZERO' IN THE ITEM-SPACE IN MEMORY
:DEP     CNAME    5  'DEPOSIT' ITEM FROM CF(2) INTO ITEM-SPACE IN MEMORY
*PASS SET S:UFV(PASS)+1  THE REAL PASS SWITCH IS SET LIKE THIS EARLIER.
OP#      SET      LW,AND,AND,STS,STS,LW,AND,LW,STW,STW
 DO PASS=1
 PROC
P,ITEMLIST SET    AF(1)
S        SET      AF(2)
N        SET      S(1)
E        SET      NUM(S)
D        SET      P(#EO)+N*(E=2)
LNG      SET      P(#LB)-P(#FB)+1
V        SET      (1**LNG-1)**(31-P(#LB)-S(2))
ADASINDX SET      AFA&E~=1&P(#AD)>0&P(#AD)<8
AAD      SET      ADASINDX=0&AFA*D>0&E~=1
LV       SET      #(V<1**19|NAME<3|LNG=WL,L(V),V)
LF(1)    RES      (NAME=4)+(NAME>2&LNG<WL)+AAD
LF(2)    RES      1
 PEND
 ELSE
 PROC
P,ITEMLIST SET    AF(1)
S        SET      AF(2)
N        SET      S(1)
E        SET      NUM(S)
D        SET      P(#EO)+N*(E=2)
LNG      SET      P(#LB)-P(#FB)+1
V        SET      (1**LNG-1)**(31-P(#LB)-S(2))
ADASINDX SET      AFA&E~=1&P(#AD)>0&P(#AD)<8
AAD      SET      ADASINDX=0&AFA*D>0&E~=1
LV       SET      #(V<1**19|NAME<3|LNG=WL,L(V),V)
CX       SET      #(NUM(CF(3)),CF(2)+1,CF(3))
LF(1)    GEN,#(NAME=4,,SPI) LI,CF(2),0
         GEN,#(NAME<3|LNG=WL,SPI) #(V<1**19,LW,LI),CF(2)+1*(NAME>3),LV
         GEN,#(AAD,,SPI) LI,CX,D
LF(2)    GEN,SO AFA*(ADASINDX=0),OP#(NAME+5*(LNG=WL)),CF(2),;
      #(ADASINDX,,P(#AD))+N*(E=1)+CX*AAD,#(ADASINDX,P(#AD)+(AFA=0)*D,D)
 ERROR,0,NUM(P)~=NIE QMA
 ERROR,0,NAME>3&CF(2)&1 QMD
 ERROR,0,AAD&CX=CF(2)+1 QMF
 ERROR,0,ADASINDX&(P(#AD)=CF(2)|P(#AD)=CX&AAD|P(#AD)=CF(2)+1&NAME>2) QMG
 ERROR,0,E=1|AAD&(CX=0|CX>7) QMI
%PEND    PEND
 FIN
*
* RETURN: :LWC GENERATES; 'LI/LW' OR JUST 'LW' ITEM FROM MEMORY.
*         :AWC GENERATES; 'LI/AND' OR JUST 'AND' ITEM FROM MEM.
*         :LAM GENERATES; 'LI/LW MASK'; 'LI/AND' OR 'AND' ITEM FROM MEM.
*         :DEPZ GENERATES; 'LI ZERO'; 'LI/LW MASK'; 'LI/STS' OR 'STS'.
*         :DEP GENERATES; 'LI/LW MASK'; 'LI/STS' OR 'STS'.
*
 CLOSE N,E,D,S,V,P,ADASINDX,CX,%P2,AAD,LNG,LV,OP#
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN NAM%,P,%A%L,S     P CAN CLOSE IMMEDIATELY, BUT %A%L CLOSES AFTER
*                 FUNCTION PROCS THAT CAN SET IT FOR :POS.
* CALL: :POSX,REG. *EVALUATABLE%EXPRESSION,INDEX
*       WHERE THE OPTIONAL AFA OR INDEX IS TO BE APPLIED TO THE
*       GENERATED SHIFT INSTRUCTION.  COMMON EXPRESSIONS INCLUDE
*       USE OF THE FUNCTION PROCS, ESPECIALLY TO RIGHT- OR LEFT-
*       JUSTIFY AN ITEM TO A WORD BOUND, EG; TO RIGHT-JUSTIFY AND SCALE
*       THE 9TH ENTRY OF AN ITEM (PREVIOUSLY FETCHED INTO 'ANYREG')
*          :POS,ANYREG  :RJ(ITEM)+:ISH(ITEM)+:SF(ITEM)
*       WHERE THE TYPE OF SHIFT (L/A) IS THE TYPE OF THE LAST NAMED ITEM.
*
:POSD    CNAME    DBL,1
:POS     CNAME    ,1
:POSAD   CNAME    ARTH|DBL
:POSCD   CNAME    CIR|DBL
:POSLD   CNAME    DBL
:POSA    CNAME    ARTH
:POSC    CNAME    CIR
:POSL    CNAME    0
 DO       TXXXFLG
::POSA   CNAME    ARTH
::POSC   CNAME    CIR
 FIN
 DO PASS=1
 PROC
%A%L     SET      0
P        SET      AF(1)
NAM%     SET      NAME(1)|ARTH*%A%L*NAME(2)
P        SET      #(((NAM%&DBL)=0&P>-32&P<-12|(NAM%&DBL)>0&P>-64&P<-22);
                  &(NAM%&CIR)>0&(AFA|AF(2))=0,P,P&WM+WL*((NAM%&DBL)>0))
LF RES (AFA|AF(2)|P&((NAM%&DBL)>0)*WL+WM)~=0
 PEND
 ELSE
 PROC
%A%L     SET      0
P        SET      AF(1)
NAM%     SET      NAME(1)|ARTH*%A%L*NAME(2)
P        SET      #(((NAM%&DBL)=0&P>-32&P<-12|(NAM%&DBL)>0&P>-64&P<-22);
                  &(NAM%&CIR)>0&(AFA|AF(2))=0,P,P&WM+WL*((NAM%&DBL)>0))
E ERROR,0,(NAM%&DBL)>0&(CF(2)&1) QMD
LF       GEN,#((AFA|AF(2)|P&((NAM%&DBL)>0)*WL+WM)=0,SO) AFA,SH,CF(2),;
                  AF(2),#(AFA,NAM%|P&SHM,P)
%PEND    PEND
 FIN
*
* RETURN: A SHIFT INSTRUCTION IS GENERATED IF THE EVALUATION OF
*         THE EXPRESSION RESULTS IN A NON-ZERO VALUE.
         SPACE 5
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* CALL: :XX(ITEMNAME)  SELECTS AN ELEMENT OF THE ITEMLIST.
*       THE NOTATION ITEMNAME(XX) IS ANOTHER, FASTER, WAY.
*       ONLY THE :ST PROC RETURNS OTHER THAN A SINGLE
*       VALUE--IT'S THE STATUSNAME/VALUE SUBLIST.
*
:FB FNAME #FB
:LB FNAME #LB
:AD FNAME #AD
:BI FNAME #BI
:EO FNAME #EO
:SF FNAME #SF
:AL FNAME #AL
:ST FNAME #ST
:NENT    FNAME    #NENT
 PROC
P SET AF
%A%L     SET      P(#AL)
 ERROR,0,NUM(P)~=NIE|NUM(AF)>1|AFA QMA
 PEND P(NAME)
         SPACE 5
*
* CALL: :XXXX(ITEMNAME,:K(N)) RETURN: THE VALUE OF THE OPERATED ALGORITHM
*
:ADEO,:AE  FNAME  3,5,NIE+1
:LN        FNAME  2,NIE+1,1,1
:LJR,:LTR  FNAME NIE+1,2,1,-WM
:JJ,:RJL,:RTL FNAME 1,NIE+1,2,WM
         PROC
P        SET      AF
%A%L     SET      P(#AL)
 ERROR,0,NUM(P)~=NIE|NUM(AF)>1|AFA QMA
         PEND     NAME(4)+P(NAME(1))+P(NAME(2))-P(NAME(3))
*
S        SET      1
:LJ      FNAME NIE+1,1,,S
:LIJ     FNAME 1,NIE+1,,-S
:RJ,:RWJ,:LBWM,:LB31 FNAME NIE+1,2,WM,S
:RIJ,:WMLB,:31LB FNAME 2,NIE+1,-WM,-S
         PROC
P,ITEMLIST SET    AF(1)
S        SET      AF(2)
S        SET      S(2)
%A%L     SET      P(#AL)
 ERROR,0,NUM(P)~=NIE|NUM(AF)>2|AFA QMA
         PEND     P(NAME(2))-P(NAME(1))-NAME(3)+NAME(4)*S
*
 CLOSE NAM%,S,P,%A%L FINALLY CLOSING %A%L OPENED BEFORE THE :POS PROC.
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN TXT
TXT SET TCOR(:ST%TEXT%SWITCH,S:FR,S:UND)=0
 CLOSE :ST%TEXT%SWITCH DISPOSE OF SWITCH NAME
* NOTE: IF ABOVE SWITCH SET NEQ ZERO BEFORE DATADEF, THE :ITEM PROC
* WILL REQUIRE STATUSNAMES TO BE 'TEXT'<=7CHARS.  IT WILL RETAIN
* THESE NAMES WITH THEIR VALUES AS THE 8TH LIST ENTRY--WHERE THEY
* MAY LATER BE FOUND BY THE :STV OR :PSTV PROC.
*
 OPEN DEFAULT,MODE,P,R,T,F,%P2,Q,%AD,%BI,@STATUS,V,W,X,I,@ERROR
*
* CALL: :ITEM(PREVIOUS%ITEMNAME,(FB, ),(LB, ),(AD, ),(BI, ),...)
*       WHERE THE VALUES SUPPLIED WITH THE KEYWORDS ARE FORMED
*       INTO A LIST OF EIGHT (THE EIGHTH BEING A POSSIBLE SUBLIST).
*       THIS FUNCTION PROC IS USED IN FORMING A DICTIONARY BY THE
*       FOLLOWING MEANS:  NAME EQU :ITEM(     )
*       IF  THIS PROC IS NOT USED, THE LIST MAY STILL BE MADE
*       PROPERLY BUT NO ERROR CHECKING OCCURS--THE ADVANTAGE IS SPEED
*       AT COMPILE TIME:  NAME EQU 0,31,0,0,0,0,0,0
*
DEFAULT SET  0,31,,,,,0,0
*
:ITEM FNAME
 DO PASS=1
 PROC
MODE SET SCOR(AF(1,1),FB,LB,AD,BI,EO,SF,ST,L,A)=0
P SET S:KEYS(MODE|2,*23,FB,LB,AD,BI,EO,SF,ST,30,L,A)
T SET #(MODE,DEFAULT,AF(1))
F SET P(2)
%AD SET AF(P(5),2),T(3)
 GOTO,(F&4)=0 %PEND
 @STATUS AF(P(9))
%PEND,LF PEND  ((F&256)=0)*T(1)+AF(P(3),2),((F&128)=0)*T(2)+AF(P(4),2),;
 %AD(((F&64)=0)+1),((F&32)=0)*T(4)+AF(P(6),2),((F&16)=0)*T(5);
 +AF(P(7),2),((F&8)=0)*T(6)+AF(P(8),2),((F&3)=0)*T(7)+(F&1),(T(#ST))
 ELSE
%P2 PROC
MODE SET SCOR(AF(1,1),FB,LB,AD,BI,EO,SF,ST,L,A)=0
P SET S:KEYS(MODE|2,*23,FB,LB,AD,BI,EO,SF,ST,30,L,A)
T SET #(MODE,DEFAULT,AF(1))
F SET P(2)
%AD SET AF(P(5),2),T(3)
 GOTO,(F&4)=0 Q
 @STATUS AF(P(9))
Q,ITEMLIST SET ((F&256)=0)*T(1)+AF(P(3),2),((F&128)=0)*T(2)+AF(P(4),2),;
 %AD(((F&64)=0)+1),((F&32)=0)*T(4)+AF(P(6),2),((F&16)=0)*T(5);
 +AF(P(7),2),((F&8)=0)*T(6)+AF(P(8),2),((F&3)=0)*T(7)+(F&1),(T(#ST))
%BI SET Q(#BI)
 GOTO,(Q(#LB)>WM|Q(#FB)>Q(#LB)|%BI~=0&(Q(#LB)-Q(#FB)+1>%BI|Q(#LB)>=%BI);
 |(%BI&WM)>0&(%BI-1&%BI)~=0)=0&S:UFV(NUM(T))=NIE %PEND
 @ERROR
%PEND,LF PEND ITEMLIST
 FIN
*
* RETURN: A LIST OF PARAMETERS IN A FIXED ORDER (WITH VALUES CHECKED FOR
*         ADHERENCE TO THE RULES) THAT DEFINES AN ITEM FOR LATER USE.
*         ITEMLIST(#ST) IS THE ONLY LIST ENTRY THAT MAY BE A SUBLIST.
*
@STATUS CNAME
 PROC
T(#ST)   SET      X'DDEF'
V SET 0
I DO NUM(AF)-1
 GOTO,TCOR(AF(I+1),S:INT)=0 W
V SET AF(I+1)
 GOTO X
W GOTO,TXT R
AF(I+1) EQU V
 GOTO V
R BOUND 1
T(#ST) SET T(#ST),V,AF(I+1)
V SET V+1
X FIN
 PEND
*             ITEMLIST(#ST) IS A SUBLIST: DDEF,V1,'T1',V2,'T2',...VN,'TN'
*
@ERROR CNAME
 PROC
 ERROR,0,NUM(T)~=NIE QMA
 ERROR,0,Q(#LB)>WM|Q(#FB)>Q(#LB)|(Q(#LB)-Q(#FB)+1>%BI)&%BI>0 QMC
 ERROR,0,(%BI&WM)~=0&(%BI-1&%BI)~=0 QMB
 ERROR,0,%BI~=0&Q(#LB)>=%BI  QME
Q(#BI) SET %BI*((%BI&WM)=0|%BI<WL&(%BI-1&%BI)=0)
 DISP Q
 PEND
*
 CLOSE TXT
 CLOSE DEFAULT,MODE,P,R,T,F,%P2,Q,%AD,%BI,@STATUS,V,W,X,I,@ERROR
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN  PAD,SKEL,MODE,B,I,P,K,II,KII,A,POST%TO%TABLE%IMAGE,;
 EM1,EM2,EM3,EM4,EM5,EM6,EM7,EM8,EM9,T%POST%TO%TABLE%IMAGE
         OPEN     Q,J,C2,C3,Z
*    *********   DISPLAY     **********
*
*        FDISP    POST%TO%TABLE%IMAGE,T%POST%TO%TABLE%IMAGE
*       *************
*
:ENTRY%TEMPLATE CNAME 0
         PROC
 ERROR,0,NUM(CF)>1 'FORMAT ERROR'
Q        SET
I        DO       NUM(AF)
J        DO       NUM(AF(I))
Q(I,J)   SET      AF(I,J)
         FIN
         FIN
LF       SET      'ESK',Q
         PEND
         SPACE    3
* THESE TWO PROCS HAVE THE FOLLOWING CALL FORMAT:
*LF(1),LF(2)  :NAME,I,J          ENTRYNAME,(ITK,V(I),V(I+1),...),(ITL,V(I)),...
* WHERE LF(1) IS THE LABEL OF THE TABLE IMAGE TO BE FORMED FROM
*       PREVIOUSLY BUILT TABLE IMAGE LF(2) PLUS THE ADDITIONAL
*       VALUES OF ITEM ENTRIES NAMED ON THIS CALL LINE.
* WHERE :NAME DESIGNATES THAT THE IMAGE IS JUST TO BE REMEMBERED
*       IF :TABLE%SET BUT IS ACTUALLY TO BE GENERATED IF :TABLE%DATA.
* WHERE THE SUBSCRIPT IN CF(2) IS THE INITIAL ENTRY TO INITIALIZE
*       ITEM VALUES INTO FROM THIS CALL LINE, AND CF(3) IS THE
*       LAST SUBSCRIPT (MUST BE LESS THAN NENT IF DEFINED).
* WHERE ENTRYNAME IS THE NAME USED TO SET UP A TEMPLATE OF
*       INITIAL VALUES FOR EACH ENTRY AND IS TO BE APPLIED
*       OVER THE RANGE OF SUBSCRIPTED ENTRIES IN THE TABLE IMAGE
*       IF IT IS PRESENT--WHICH IS OPTIONAL.
* WHERE SUBLISTS OF ITEMNAME (PREVIOUSLY DEFINED VIA :ITEM) AND
*       VALUES ARE TO BE APPLIED OVER THE RANGE OF SUBSCRIPED
*       ENTRIES IN THE TABLE IMAGE, AND OVER THE VALUES SET THERE
*       BY THE ENTRYNAME TEMPLATE.  IF VALUES RUN OUT BEFORE SUBSCRIPTS
*       DO ZEROS ARE USED FOR THE REMAINDER OF THE RANGE OF ENTRIES.
:TABLE%SET CNAME  0+FLAGS(SDFLG,1)
:TABLE%DATA CNAME 1+FLAGS(SDFLG,1)
PAD      SET      0
         PROC
SKEL     SET      AF(1)
MODE     SET      SKEL(1)='ESK'
B        SET      #(NUM(LF),,#(TCOR(LF(1),S:FR),LF(1)),LF(2))
C2       SET      CF(2)
C3       SET      CF(3)
         SET             #(MODE,,T%POST%TO%TABLE%IMAGE(AF(1)))
         SET             #(NUM(AF)-MODE>0,,POST%TO%TABLE%IMAGE(AF))
         DO       NAME
LF(1)    DATA     B
         ELSE
LF(1)    SET      B
         FIN
B        SET
         PEND
EM1      SET      'DATADEF DOES NOT ALLOW MINUS EO VALUES IN THIS PROC'
EM2 SET 'DATADEF ITEMS MUST ALL HAVE THE SAME AD VALUE IN THIS USE'
EM3 SET 'DATADEF SUBSCRIPT EXCEEDS DEFINED NENT OR FIRST EXCEEDS LAST'
EM4 SET 'DATADEF FOUND A NONZERO VALUE ALREADY STORED HERE'
EM5 SET 'DATADEF CANNOT PACK THIS VALUE IN LESS THAN 32 BITS'
         SPACE 3
 DO  SDFLG
T%POST%TO%TABLE%IMAGE FNAME 0
         PROC
Z        SET      AF
I        DO       S:UFV(NUM(Z))-MODE
P,ITEMLIST SET    Z(I+MODE,1)
P(#NENT) SET      #(P(#NENT)=0,P(#NENT),(255*WL)/P(#BI))
 ERROR,0,P(#EO)<0  EM1
 ERROR,0,P(#AD)-PAD~=0&I>1 EM2
K        SET      :K(C2),:K(C3)
K(1)     SET      #(K(1)>P(#NENT),K(1),P(#NENT)|ERRMSSG(3))
K(3)     SET      #(K(3)>P(#NENT),K(3),P(#NENT)|ERRMSSG(3))
K(3)     SET      #(K(3)<K(1),K(3),K(1)+ERRMSSG(3,C3=0))
II       DO        K(3)-K(1)+1
KII      SET      :K(II-1)
A        SET      :EO(P)+K(1)+KII(1)+1
 ERROR,0,(B(A)&:M((P,(,K(2)+KII(2)&31))))>0      EM4
         DO       TCOR(Z(I+MODE,1+II),S:EXT,S:AAD,S:RAD,;
                  S:LFR,S:SUM)>0
B(A)     SET      Z(I+MODE,1+II)
  ERROR,0,P(#LB)-P(#FB)<WM EM5
         ELSE
B(A)     SET      B(A)&:C((P,(,K(2)+KII(2)&31)))|(Z(I+MODE,1+II)&;
                  :RJMI(P))**:RIJ(P,(,K(2)+KII(2)&31))
         FIN
         FIN
PAD      SET      P(#AD)
         FIN
         PEND
         SPACE 3
POST%TO%TABLE%IMAGE FNAME 0
         PROC
I        DO       NUM(AF)-MODE
P,ITEMLIST SET    AF(I+MODE,1)
P(#NENT) SET      #(P(#NENT)=0,P(#NENT),(255*WL)/P(#BI))
 ERROR,0,P(#EO)<0  EM1
 ERROR,0,P(#AD)-PAD~=0&I>1 EM2
K        SET      :K(C2),:K(C3)
K(1)     SET      #(K(1)>P(#NENT),K(1),P(#NENT)|ERRMSSG(3))
K(3)     SET      #(K(3)>P(#NENT),K(3),P(#NENT)|ERRMSSG(3))
K(3)     SET      #(K(3)<K(1),K(3),K(1)+ERRMSSG(3,C3=0))
II       DO        K(3)-K(1)+1
KII      SET      :K(II-1)
A        SET      :EO(P)+K(1)+KII(1)+1
 ERROR,0,(B(A)&:M((P,(,K(2)+KII(2)&31))))>0      EM4
         DO       TCOR(AF(I+MODE,1+II),S:EXT,S:AAD,S:RAD,;
                  S:LFR,S:SUM)>0
B(A)     SET      AF(I+MODE,1+II)
  ERROR,0,P(#LB)-P(#FB)<WM EM5
         ELSE
B(A)     SET      B(A)&:C((P,(,K(2)+KII(2)&31)))|(AF(I+MODE,1+II)&;
                  :RJMI(P))**:RIJ(P,(,K(2)+KII(2)&31))
         FIN
         FIN
PAD      SET      P(#AD)
         FIN
         PEND
 FIN
 CLOSE PAD,SKEL,MODE,B,I,P,K,II,KII,A,POST%TO%TABLE%IMAGE,;
 EM1,EM2,EM3,EM4,EM5,EM6,EM7,EM8,EM9,T%POST%TO%TABLE%IMAGE
         CLOSE    Q,J,SDFLG,C2,C3,Z
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN P
* CALL: :BIA(ITEMNAME,:K(CONSTANT%SUBSCRIPT))
* CALL: :ISH(ITEMNAME,:K(CONSTANT%SUBSCRIPT))
*
:BIA FNAME 1 INTER-WORD BIAS--THIS RETURNS THE NO.OF WORDS TO ADD TO THE
* #AD & #EO TO GET THE EFFECTIVE ADDRESS OF THE :K(N)TH ITEM ENTRY.
*
:ISH FNAME 2 INTRA-WORD SHIFT--THIS RETURNS THE VALUE OF THE SHIFT
* THAT WILL JUSTIFY THE :K(N)TH ITEM ENTRY TO THE ZEROTH ITEM ENTRY(#LB)
 PROC
ITEMLIST SET AF(1)
P SET AF(2)
 ERROR,0,NUM(P)~=2 QMA
 PEND P(NAME)    RETURN :BIA OR :ISH VALUE
 CLOSE P
*
* USE THIS AFTER   LW,R :ADEO+:BIA   OR LW,R :EO+:BIA,:AD ETC.
* AS FOLLOWS:   :POSL,R :ISH(ITEMN,:K(N)) TO MOVE ITEM TO #LB POSITION
* OF ENTRY ZERO.  IN ANOTHER EXAMPLE; TO RIGHT-JUSTIFY TO BIT 31--
* AFTER :LWC;   :POSL,R :RJ(ITEMN)+:ISH(ITEMN,:K(N)) --AND TO LEFT-JUST.
* TO BIT 0;     :POSA,R :LJ(ITEMN)+:ISH(ITEMN) IS USED AFTER :LWC,
* WHERE :ISH IS ADDED FOR EITHER LEFT OR RIGHT SHIFT COMPENSATION
* IF ENTRY DOES NOT COINCIDE WITH THE ZEROTH ENTRY POSITION (IE, BI<WL)
* NOTE: :ISH IS ADDED TO SHIFT AWAY, SUBTRACTED TO SHIFT TOWARD THE ITEM.
*
* THE SAME EFFECT FOR A VARIABLE SUBSCRIPT IS OBTAINED BY:
* FOR BI = 1, 2, OR 4 --
*   SHIFTING THE INDEX  SCS,X :BI(ITEM)**-1-5 TO SECURE THE BIAS
*   RIGHT- JUSTIFIED IN THE INDEX--LATER DOING SLS,X -27 TO RIGHT-
*   JUSTIFY THE INTRAWORD SHIFT VALUE. PRESAVE ORIG.VALUE OF X IF NEEDED
* FOR BI = 64 AND ABOVE --
*   MULTIPLYING THE INDEX BY  :BI(ITEM)**-5+OPCODERESOLUTION,
*   FOR BIAS  AND USING :RJ(ITEM) FOR INTRAWORD SHIFT.
* FOR BI = 8, 16, OR 32 --
*   JUST USE THE INDEX AS IT STANDS WITH A BYTE, HALF, OR WORD RESOL.
*   COMMAND, RESPECTIVELY, FOR :BIA & THEN SHIFT RIGHT 7-#LB, 15-#LB, OR
*   31-#LB, RESPECTIVELY, TO RIGHT JUSTIFY THE ITEM VALUE.
         SPACE 5
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN N,E,D,S
* CALL: :PV((ITEM1,:K(N1)),X'E',(ITEM2,:K(N2)),2,...(ITEMN,:K(NN)),1+2)
*       WHERE THE MOST COMPLICATED ARGUMENT IS SHOWN WITH OPTIONS
*
*       A SINGLE ITEMNAME/VALUE PAIR IS THE MOST TYPICAL CASE--
*       MULTIPLE PAIRS RESULT IN THE LOGICAL 'OR' OF THE RESULTANT
*       VALUES.  THE VALUE TO BE SET WITHIN ITEM BOUNDS (THE EVEN
*       SUBSCRIPTS OF AF) CAN BE ANY EVALUATABLE EXP.
*
:PV FNAME 0   POSITIONED VALUE (OR LOGICAL 'OR' OF SEVERAL VALUES)
         PROC
N        SET      0
E        DO       NUM(AF)/2
D,ITEMLIST SET    AF(E*2-1,1)
S SET AF(E*2-1,2) EVALUATE :K(N) SUBSCRIPT, IF ANY
 ERROR,0,NUM(D)~=NIE|AFA QMA
N SET N|(AF(E*2)&(1**(D(#LB)-D(#FB)+1)-1))**(WM-D(#LB)-S(2))
         FIN
         PEND     N
*
* RETURN: THE VALUE(S) IN THE REQUESTED ITEM POSITIONS--NOT A LITERAL
*         AT THIS POINT--THAT WOULD REQUIRE L(:PV(ITEMN,VAL)).
         SPACE 5
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* CALL: :M(ITEM1,(ITEM2,:K(N2)),...ITEMN) RETURN: VALUE OF THE MASK(S)
*       :C((ITEM1,:K(N1)),...)  RETURN: VALUE OF THE CMASK(S)
*       ALLOWING FOR INTRA-WORD SHIFT AS DICTATED BY THE SUBSCRIPT
*
:M,:MASK   FNAME  0
:C,:CMASK  FNAME  -1
         PROC
N        SET      0
E        DO       NUM(AF)
D,ITEMLIST SET    AF(E,1)
S SET AF(E,2)
 ERROR,0,NUM(D)~=NIE|AFA QMA
N SET N|(1**(D(#LB)-D(#FB)+1)-1)**(WM-D(#LB)-S(2))
         FIN
         PEND     NAME||N
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* CALL: :RJXX(ITEMNAME)
*       :RJXI   REQUESTS THE VALUE BE RETURNED
*       :RJX    REQUESTS THE LITERAL ADDRESS OF THE VALUE BE RETURNED
*
:RJMI    FNAME    0
:RJCI    FNAME   -1
:RJM     FNAME    0,1
:RJC     FNAME   -1,1
         PROC
N        SET      AF
E        SET      1**(N(#LB)-N(#FB)+1)-1
 ERROR,0,NUM(N)~=NIE|NUM(AF)>1 QMA
         PEND     #(NAME(2),NAME(1)||E,L(NAME(1)||E))
*
* RETURN: THE VALUE (OR ITS LITERAL ADDRESS) OF THE RIGHT-JUSTIFIED
*         MASK OR COMPLEMENT MASK OF THE NAMED ITEM.
 CLOSE N,E,D,S
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN N,I,X,Y,STVAL,U
* CALL: :PSTV(ITEMNAME,('NAME1',:K(J)),...('NAMEN',:K(J+N-1)))
* CALL: :STV(ITEMNAME,'NAME1','NAME2',...'NAMEN')
*       THE STATUS VALUE(S) FOR ITEMNAME REPRESENTED BY AF(2) THROUGH
*       AF(N) TEXT NAMES (NOT TO EXCEED 7 CHARS.) ARE RETURNED IF THEY
*       CAN BE FOUND IN THE 8TH ELEMENT OF THE ITEMLIST.  THE VALUE IS
*       RETURNED RIGHT-JUSTIFIED (:STV) OR 'NATURALLY'-JUSTIFIED (:PSTV)
*
:PSTV FNAME 1
:STV FNAME 0
 PROC
N SET AF(1)
STVAL SET 0
U DO NUM(AF)-1
I DO (NUM(N(#ST))-1)/2
 GOTO,N(#ST,2*I+1)=AF(1+U,1) X
 FIN
 ERROR,0 'DATADEF ITEM STATUS NAME UNDEFINED'
 GOTO Y
X SET AF(1+U,2)
STVAL SET N(#ST,2*I)**(NAME*(WM-N(#LB)-X(2)))|STVAL
Y FIN
 ERROR,0,NUM(AF)<2|NUM(N)~=NIE QMA
%PEND PEND STVAL
*
* RETURN: THE LOGICAL 'OR' OF ALL THE VALUES THAT WERE FOUND IN
*         ITEMLIST(8) THAT WERE REFERENCED BY THE TEXT NAMES
*         FOLLOWING AF(1) OF THIS PROC
 CLOSE N,I,X,Y,STVAL,U
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN  N,E,D,S,V,P
* CALL: LABEL :XXX,ANYREG  ITEMNAME,:K(CONSTANT)
*       WHERE THE REG IS CONSIDERED TO CONTAIN AN ITEM IN ITS
*       NATURAL POSITION, NAT.POS.MODIFIED BY :K, OR RIGHT-JUST.
*
:XRJ,:ERJ  CNAME  -1
:XTR,:ETR  CNAME   0
:JAM,:EAJ  CNAME   1
:ZRJ       CNAME  -1,-1
:ZER       CNAME   0,-1
:JAC       CNAME   1,-1
 DO       TXXXFLG
::XTR    CNAME    0
 FIN
 PROC
P,ITEMLIST SET    AF(1)
V        SET      NAME(1)
S        SET      AF(2)
N        SET      #(P(#AL)&NAME(2)=0,P(#LB)-WM,P(#FB))+S(2)
E        SET      P(#LB)-WM-P(#FB)
D        SET      V*P(#AL)~=1|NAME(2)<0
LF(1)    GEN,#(V=1&N~=0,,SP) SH,CF(2),,#(N>20,N,WL-N)&SHM|CIR*(P(#AL)|;
                  NAME(2)<0)
LF(2)    GEN,#(E=0|P(#FB)+S(2)=0&P(#AL)=0&V=1,SP) #(D,SH,AND),CF(2),,;
    #(D,E&SHM|ARTH,L(NAME(2)||(1**(E+WL)-1)**((V=0)*(WM-P(#LB)-S(2)))))
 ERROR,0,NUM(P)~=NIE|NUM(AF)>1&NUM(AF(2))>1|AFA QMA
%PEND    PEND
*
* RETURN: A MAXIMUM OF TWO INSTRUCTIONS IS GENERATED (WORST CASE)
*         TO ACCOMPLISH THE REQUESTED FUNCTION ON THE ITEM IN ITS
*         STATED POSITION WITHIN THE REG.
 CLOSE N,E,D,S,V,P
         SPACE 5
 OPEN V,WORD,IMMED,ITEM,ADRFLAG,:ADR THE IDEA HERE IS NOT TO WORRY ABOUT USING I
* MEDIATE ADDRESSING.  IT BECOMES ENTIRELY PARAMETERIZED.
* THE ARGUMENT CAN BE A VALUE-CONSTANT (WILL BE LITERALIZED OR NOT),
* AN ITEM-NAME (WILL BE FETCHED, FETCHED &ADDED, OR FETCHED &COMPARED),
* OR AN ADDRESS (MUST BE THE ARGUMENT OF :ADR(  ), AND CAN BE * OR ,X).
LK,LIW   CNAME    LW,LI+FLAGS(KIFLG,1)
AK,AIW   CNAME    AW,AI+FLAGS(KIFLG,1)
CK,CIW   CNAME    CW,CI+FLAGS(KIFLG,1)
 DO     KIFLG
::CK     CNAME    CW,CI
 FIN
ADRFLAG  SET      0
 PROC
V        SET      AF(1) IF :ADR( ) APPEARED, ADRFLAG WILL BE = 1.
LF       RES       0
 SET #((ADRFLAG=0)*((NUM(V)=NIE)*2|NUM(AF)=1&NUM(V)=1&AFA=0&V(1)<1**19);
     ,WORD,IMMED,ITEM)
ADRFLAG SET 0
 PEND
 DO       KIFLG
WORD FNAME 0
 PROC
         GEN,SO   AFA,NAME(1),C2,AF(2),#(ADRFLAG,L(V),V)
 PEND
IMMED FNAME 0
 PROC
         GEN,SPI  NAME(2),C2,V
 PEND
ITEM FNAME 0
* FETCH ITEM INTO REGISTER AND, IF WANTED, ADD OR COMPARE.
 PROC
         :FETCH,C2,C3   AF(1)
         DO       NAME(1)=CW
         ::CK,C2  AF(2)
         FIN
 PEND
:ADR FNAME 0
 PROC
ADRFLAG SET 1
 PEND AF
 FIN
 CLOSE V,WORD,IMMED,ITEM,ADRFLAG,TXXXFLG,KIFLG
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN P,Q,R,S,T,W,X,Y,Z,QMJ,NP,NQ,NR,COUNTR,AFA3,PLEN,QLEN,A1,A2;
 ,A3,A4,PXK,P2NXK,QXK,Q2NXK,STRING1X,STRING2X,AFA1,AFA2,LSO,OP#,PBI4
* LABEL :COPY,EVENREG,IX,WRK  (*ITEM1,X),(:ITEM2,X),(*ITEM3,X)
*       WHERE THE MOST COMPLICATED ARGUMENT IS SHOWN, AND THE 3
*       ARGUMENTS ARE THE 'FROM', 'TO', AND 'COUNT' PARAMETERS.
*       WHEN THE 'FROM' OR 'TO' PARAMETER IS SUBSCRIPTED IN ANY WAY,
*       IT INDICATES THE BEAD OF THE ITEM STRING THAT IS THE FIRST TO
*       BE AFFECTED.  'COUNT' INDICATES THE TOTAL NUMBER OF BEADS TO BE
*       COPIED FROM STRING 1 TO STRING 2.  IF 'COUNT' IS WRITTEN AS A
*       CONSTANT (:K(CONSTANT)), A MEMORY OR REGISTER LOC.(*ADDR.,X)
*       , OR AN ITEM (*ITEM,X)--IT WILL BE ACCESSED ONLY ONCE AND USED
*       FOR TRANSFER-LOOP CONTROL.
*
*       REGISTERS:  THE EVENREG PAIR IN CF(2) AND THE WORK INDEX CF(3)
*       WILL BE USED BY ANY :FETCH/:STORE PROCS CALLED, AND THE REGISTER
*       CF(2)+2 REGISTER IS USED IF NO CF(4) REGISTER IS NAMED (0-15).
*       ADDITIONALLY, THE EVENREG INDEX PAIR LESS THAN CF(2) IS USED.
*       SUMMING UP--CF(2)-2 THROUGH CF(2)+2 ARE WORK REGISTERS, CF(3)
*       IS A WORK INDEX, AND CF(4) OPTIONALLY REPLACES CF(2)+2.
*       NATURALLY, NONE OF THESE MAY CONFLICT WITH ADDRESS POINTERS OR
*       VARIABLE SUBSCRIPTS OF AF(1)...AF(3) WITHOUT ERROR DIAGNOSTICS.
QMJ EQU 'DATADEF :COPY AF(1) MISMATCHES AF(2)'
*
:COPY CNAME 0+FLAGS(COPYFLG,1)
:FILL CNAME 1+FLAGS(COPYFLG,1)
 PROC
ITEMLIST(#BI) SET WL ALL :K'S GET FULL VALUE IN 'BIAS', 0 IN 'ISH'.
P SET AF(1,1)
PXK SET AF(1,2)
NP SET NUM(AF(1))
P2NXK SET NUM(PXK)
Q SET AF(2,1)
QXK SET AF(2,2)
NQ SET NUM(AF(2))
Q2NXK SET NUM(QXK)
R SET AF(3,1)
NR SET NUM(R)<2 NUM(R) =1 IF PLAIN ADDRESS, =2 IF :K( ), =NIE IF ITEM
COUNTR SET #(CF(4)=0|CF(4)>7,CF(4),CF(2)+2)
PLEN SET P(#LB)-P(#FB)+1
QLEN SET Q(#LB)-Q(#FB)+1
 ERROR,0,NUM(CF)<4 'DATADEF :COPY/:FILL REGISTER DEFAULTS USED'
 ERROR,0,NUM(P)~=NIE|NUM(Q)~=NIE QMA
 ERROR,0,PLEN>QLEN|P(#AL)~=Q(#AL)|P(#BI)~=Q(#BI)  QMJ
AFA1 SET AFA(1,1)|AFA(1)
AFA2 SET AFA(2,1)|AFA(2)
AFA3 SET AFA(3,1)|AFA(3)
LF(1) RES 0
 GOTO,NUM(R)=NIE W
 GOTO,NUM(AF(3))<2&AFA3=0&R(1)=0 %PEND
 GEN,SO AFA3*NR,#(AFA3|NUM(AF(3))>1|NR,LI,LW),COUNTR,AF(3,2)*NR,R(1)
 GOTO X
W BOUND 1
  :GET,COUNTR,CF(2)-1 AF(3)
X GOTO,(P(#BI)=QLEN&Q(#BI)=PLEN)&P(#BI)>4     CONTIGUO
* BR.IF BOTH SETS OF BEADS ARE CONTIGUOUSLY STRUNG AND ARE BYTES,HWDS,WDS.
STRING1X SET #(P2NXK=1,CF(2)-1,AF(1,2))
STRING2X SET #(Q2NXK=1,CF(2)-1-(P2NXK~=1),AF(2,2))
 GEN,#(P2NXK=1|NAME=1,SPI) LI,STRING1X,PXK(1)
 GEN,#(Q2NXK=1,SPI) LI,STRING2X,QXK(1)
 GEN,#(Q2NXK,,SP) AW,COUNTR,,STRING2X
Y SET %
 ERROR,0,P2NXK>0&P(#BI)=0|Q2NXK>0&Q(#BI)=0 'DATADEF :COPY/:FILL (#BI)=0'
 :GET,CF(2),CF(3) AF(1,1),STRING1X
Z SET %
 :PUT,CF(2),CF(3)  AF(2,1),STRING2X
 GEN,#(NAME=1,SPI) AI,STRING1X,+1
 GEN,SPI AI,STRING2X,+1
 GEN,SP CW,STRING2X,,COUNTR
   GEN,SP  BCS,1,,#(NAME,Y,Z)
 GOTO %PEND
CONTIGUO ERROR,0,NUM(R)=2&R(1)>255 'DATADEF :COPY/:FILL MAXIMUM ',;
 'COUNT = 255 FOR CONTIGUOUS BEADS--LOOP BACK TO LF(1)'
PBI4 SET P(#BI)**-4
OP# SET #(PBI4,LBY,LH,LW)
 GEN,SP ANLZ,CF(2),,LSO(AFA1,OP#,,PXK(1)*(P2NXK=1),P(#AD))
 GEN,SP ANLZ,CF(2)+1,,LSO(AFA2,OP#,,QXK(1)*(Q2NXK=1),Q(#AD))
 GEN,#(PBI4=0,SP) SH,CF(2),,PBI4&SHM|DBL
 GEN,#(Q(#EO)~=0|Q2NXK=2,,SPI) AI,CF(2)+1,Q(#EO)**2+(Q2NXK=2)*QXK(1)**;
 PBI4
 GEN,#(PBI4=0,SP) SH,COUNTR,,PBI4
 GEN,SP STB,COUNTR,,CF(2)+1
 GEN,SPI MBS,CF(2),P(#EO)**2+(P2NXK=2)*PXK(1)**PBI4
%PEND PEND
*
 DO    COPYFLG
LSO      FNAME 0
         PROC
         PEND L(AF(1)**WM+(AF(2)**24)+((AF(4)&7)**17)+S:UFV(AF(5)))
 FIN
*
* RETURN: THE BEAD(S) FROM ITEM(STRING)1 COPIED TO THE BEAD(S) OF
*         ITEM(STRING)2
 CLOSE P,Q,R,S,T,W,X,Y,Z,QMJ,NP,NQ,NR,COUNTR,AFA3,PLEN,QLEN,A1,A2;
 ,A3,A4,PXK,P2NXK,QXK,Q2NXK,STRING1X,STRING2X,AFA1,AFA2,LSO,OP#,PBI4
 CLOSE    COPYFLG
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN NOADINDX,EOASINDX,I,F,AF2V,%GENC,C2,C3,LA,OS,OP,LJIHWD,LOC%NEXT
 OPEN NO%X4X64,PAD,PBI,PFB,A1A,NAFA,%P2,GENAND,ANDSKIP,SHFSKIP,@ERRGET
 OPEN N,E,D,%EV,AN,S,%S,ANS,LNG,LLNG,P,Q,Q1,Q2,R,V,X4,X64,Y1,Y2,Z
 OPEN FETCH%X4,FETCH%X64,FETCH%EO%AD,JXXX%SERIES,FETCH%WORD
 OPEN FETCH%PLAIN%K%X8%X16,AX,NEO,M12,CM12,M32,R#,%P,EMAN,WORD%JXXX
 OPEN SET%VARIABLES
M12      SET      -12&SHM
CM12     SET      M12|CIR
M32      SET      -WL&SHM
*
*PASS SET S:UFV(PASS)+1  THE REAL PASS SWITCH IS SET LIKE THIS EARLIER.
* FOR THESE PROCS A PASS-SWITCH IS USED.  IN PASS1,
* THE RES ARGUMENT ADDITIVE ELEMENTS EACH REPRESENT THE SWITCH FOR A GEN
* --IN THE SAME ORDER AS THE GENS OCCUR.  THE PASS1 RES WILL EQUAL THE
*   PASS2 GENS AND THE LOC COUNTERS WILL STAY IN SYNC.
*
F FNAME 0  THIS CRUTCH PROC IS USED ONLY BY THE :GET/:FETCH/:JXXX PROC
   PROC
I SET AF(1)    IT SETS 'I' VARIABLE FOR THE INTRA-WORD BYTE OR HW NO.
   PEND (I>0)*AF(2)    AND PASSES BACK THE OPCODE SELECTOR IF 'I' > 0.
*
R#       SET      LW,LH,LBY
*
:GET,:FETCH  CNAME 0
:JE      CNAME BCR,3
:JG      CNAME BCS,2
:JGE     CNAME BCR,1
:JL      CNAME BCS,1
:JLE     CNAME BCR,2
:JNE     CNAME BCS,3
:JAZ     CNAME BCR,4
:JANZ    CNAME BCS,4
:JEZ     CNAME BCR,3,1
:JNEZ    CNAME BCS,3,1
:JGZ     CNAME BCS,2,1,1
:JGEZ    CNAME BCR,1,1,1
:JLZ     CNAME BCS,1,1,1
:JLEZ    CNAME BCR,2,1,1
         PROC
LF(1)    RES      0
EMAN     SET      NAME
C2       SET      CF(2)
C3       SET      CF(3)
A1A      SET      AFA(1,1)|AFA(1)
NAFA     SET      A1A=0
P,ITEMLIST SET    AF(NAME(1)>0,1)
Q        SET      AF(NAME(1)>0,2)
 ERROR,0,NUM(P)~=NIE    QMA
 ERROR,0,C2>15|NUM(CF)<2 QMH
IX       SET      NUM(Q)=1
Q1       SET      Q(1) POS.--EVEN THOUGH THE #EO ATTRIBUTE MAY BE NEG.
AN       SET      P(#EO)+Q1*(NUM(Q)=2) #EO CAN BE NEG., BUT NOT Q1
NEO      SET      A1A*AN=0
AX       SET      A1A&#(TCOR(P(#AD),S:INT),,P(#AD)>0&P(#AD)<8)&IX=0
LNG      SET      (P(#LB)-P(#FB)&WM)+1
 GOTO,#(LNG=WL&P(#BI)<=WL,SET%VARIABLES,FETCH%WORD(AF),FETCH%DBL%WD(AF);
         ,FETCH%LM(AF)) LOC%NEXT
 SET #(X4|X64*2,FETCH%PLAIN%K%X8%X16,FETCH%X4,FETCH%X64)
 SET  #(NUM(NAME)<2,JXXX%SERIES(AF))
LOC%NEXT SET       %
%PEND    PEND
         SPACE       5
SET%VARIABLES FNAME 0
         PROC
Q2       SET      Q(2)
Y1       SET      P(#FB)+Q2
Y2       SET      P(#LB)+Q2
R        SET      R#(#((Y2&24)**-2+P(#AL)|F(0),;
                 #(NEO,2*((Y1=0&Y2=7)|(AX=0)*(Y1=0&Y2<7|Y2=7&Y1>0)),2),;
                  (Y1=0|2*(Y1>5))*(NEO|(NEO|AX)=0),;
                 #(Y1>7&(Y1=BL|Y2=15),NEO&AX=0&IX,F(1,2)),;
                  (Y1=0|Y1>10)*(NEO|(NEO|AX)=0),;
                 #((Y1=HL)+(Y2=23),0,F(2*(Y1>15)*(AX=0)*A1A,2),F(2,2)),;
                 #(Y1=HL,F(2*(Y1>HL)*(AX=0)*A1A,2),F(1,1)),;
                 #((Y1=24)+(Y2=31),0,F(3*(Y1>23)*(AX=0)*A1A,2),F(3,2)),;
                  F(Y1=HL,1))+1)
OP       SET     #(IX,R,#(P(#BI)<=WL,R,F(0)|#((P(#BI)**-3)*(P(#BI)<;
                 WL),LW,LBY,LH)))
EOASINDX SET      (NEO&I=0)=0
NOADINDX SET      (AX&OP=LW)=0
X4       SET      IX&P(#BI)<BL
X64      SET      IX&P(#BI)>WL
LJIHWD   SET      OP=LH&(P(#FB)&15)=0
ANDSKIP  SET      OP=LBY&(Y1&7)=0|OP~=LH&Y1=0&X4=0
GENAND   SET      ((P(#AL)=0)*ANDSKIP|P(#AL)*(LNG=WL|LNG=HL&OP=LH))=0
OS       SET      OP**-5-1
ANS      SET    (#(P(#AL),Y2-WM,Y1)+#(OS,,HL*(I=0),#(I,3,2,1,)*BL))&SHM
D        SET      X4|X64
%S       SET     #(C3=0|X4&C3>7|X64&(C3&1)=0,C3,(X4=0)*(C2|1)|X4*(C2+1))
V    SET #(D,#(EOASINDX&NOADINDX,IX*Q1,%S),#((X4|X64&Q&1)&%S>7,;
         %S,Q))
%PEND    PEND
         SPACE    5
JXXX%SERIES FNAME 0
 DO PASS=1
 PROC
AF2V     SET      AF(2)
*
%GENC    SET    (NUM(EMAN)>2&(ANS=0|P(#AL)&LJIHWD))&(D&V=Q1)=0
LA       SET      #(AF2V<1**19|%GENC,L(AF2V),)
LF(2)    RES      (%GENC=0)+1
 PEND
 ELSE
 PROC
%P2 ERROR,0,NUM(AF)~=3 QMN
AF2V     SET      AF(2)
*
%GENC    SET    (NUM(EMAN)>2&(ANS=0|P(#AL)&LJIHWD))&(D&V=Q1)=0
LF(2)  GEN,#(%GENC,SPI) #(AF2V<1**19|%GENC,(CW,C2,L(AF2V)),(CI,C2,AF2V))
 ERROR,0,AF2V=0&EMAN(2)=4|AF2V~=0&NUM(EMAN)>2 QMJ
         GEN,SO   AFA(3)|AFA(3,1),EMAN(1),EMAN(2),AF(3,2),AF(3,1)
%PEND    PEND
 FIN
         SPACE       5
FETCH%WORD FNAME 0
         PROC
 DO NEO=0&AX=0
 ERROR,0,(C3=0|C3>7)&IX&AX=0       QMM
         GEN,SPI  LI,C3,AN
         GEN,#(IX,,SP)  AW,C3,,Q1
         GEN,SO   A1A,LW,C2,C3,P(#AD)
 ELSE
  GEN,SO   #(AX,A1A),LW,C2,#(AX,Q1*IX,P(#AD)),#(AX,P(#AD)+NAFA*AN,AN)
 FIN
 SET #(NUM(EMAN)<2,WORD%JXXX(AF),)
%PEND    PEND     1
         SPACE    5
WORD%JXXX FNAME 0
         PROC
 ERROR,0,NUM(AF)~=3 QMN
AF2V     SET      AF(2)
 GOTO,NUM(EMAN)>2 E
LF(2)  GEN,SPI     #(AF2V<1**19,(CW,C2,L(AF2V)),(CI,C2,AF2V))
E ERROR,0,AF2V=0&EMAN(2)=4|AF2V~=0&NUM(EMAN)>2 QMJ
         GEN,SO   AFA(3)|AFA(3,1),EMAN(1),EMAN(2),AF(3,2),AF(3,1)
%PEND    PEND     1
         SPACE    5
FETCH%PLAIN%K%X8%X16 FNAME 0
 DO PASS=1
 PROC
 RES (EOASINDX&NOADINDX)+(IX&EOASINDX&NOADINDX)+1;
                +((ANS=0|P(#AL)&LJIHWD)=0)+GENAND
LLNG SET #(P(#AL)|ANDSKIP,L(1**LNG-1),)
 PEND
 ELSE
 PROC
 GOTO,(EOASINDX&NOADINDX)=0  E
 ERROR,0,V=0|V>7 QMM
         GEN,SPI   LI,V,(A1A*AN)**OS+I
         GEN,#(IX,,SP)       AW,V,,Q1
E ERROR,0,IX&(P(#BI)=0|Q1=0|Q1>7)      QMI
         GEN,SO   NOADINDX*A1A,OP,C2,#(NOADINDX,P(#AD),V),#(NOADINDX;
                  ,AN,P(#AD)+NAFA*AN)
 GOTO,ANS=0|P(#AL)&LJIHWD LLNG
         GEN,SP  SH,C2,,#(P(#AL),;
 #((ANS<M32&ANS>M12)*(Y1~=0|OP=LH),ANS,ANS&WM|CIR),ANS+(ANS>20)*CM12)
LLNG     SET      #(P(#AL)|ANDSKIP,L(1**LNG-1),)
 GOTO,GENAND=0 %PEND
 GEN,SP #(P(#AL),AND,SH),C2,,#(P(#AL),LLNG,(LNG-WL+HL*LJIHWD)&SHM|ARTH)
%PEND    PEND
 FIN
         SPACE    5
FETCH%X4 FNAME 0
 DO PASS=1
 PROC
 RES 1+(V~=Q&V>7)
V        SET       #(V~=Q&V>7,V,Q)
 RES (EOASINDX&NOADINDX)+4+GENAND+(V=Q1)
LLNG SET #(P(#AL)|ANDSKIP,L(1**LNG-1),)
 PEND
 ELSE
 PROC
         GEN,SP     LW,%S,,Q
         GEN,#(V~=Q&V>7,,SP)  XW,Q,,V
V        SET      #(V~=Q&V>7,V,Q)
 ERROR,0,C3=0    QML
    GEN,#(EOASINDX&NOADINDX,,SPI) AI,V,((A1A*AN)**OS+I)**-(P(#BI)**-1-5)
         GEN,SPI      SH,V,(P(#BI)**-1-5)&SHM|CIR
 ERROR,0,EOASINDX&NOADINDX&(V=0|V>7) QMM
 ERROR,,A1A&#(TCOR(P(#AD),S:INT),,P(#AD)=V)&V>0&(EOASINDX&NOADINDX) QMG
 ERROR,0,(P(#BI)=0|Q1=0|Q1>7)  QMI
         GEN,SO   NOADINDX*A1A,OP,C2,#(NOADINDX,P(#AD),V),#(NOADINDX;
                  ,AN,P(#AD)+NAFA*AN)
         GEN,SP      SH,V,,-27&SHM
         GEN,SP     SH,C2,V,#(P(#AL),;
         #(ANS<M32&ANS>M12,ANS,ANS&WM|CIR),ANS+(ANS>20)*CM12)
LLNG     SET      #(P(#AL)|ANDSKIP,L(1**LNG-1),)
 GOTO,GENAND=0 %P
 GEN,SP #(P(#AL),AND,SH),C2,,#(P(#AL),LLNG,(LNG-WL+HL*LJIHWD)&SHM|ARTH)
%P       BOUND    1
         GEN,#(V=Q1,,SP) LW,Q,,%S
%PEND    PEND
 FIN
         SPACE     5
FETCH%X64 FNAME 0
 DO PASS=1
 PROC
 RES 2+(V~=Q&V>7)
V        SET      #(V~=Q&V>7,V,Q)
 RES (EOASINDX&NOADINDX)+1+((ANS=0|P(#AL)&LJIHWD)=0)+GENAND+(V=Q1)
LLNG SET #(P(#AL)|ANDSKIP,L(1**LNG-1),)
 PEND
 ELSE
 PROC
         GEN,(SP,SPI)    LW,%S,,Q,MI,V,P(#BI)**(OS-5)
         GEN,#(V~=Q&V>7,,SP)  XW,Q,,V
 ERROR,0,(V&1)=0     QMK
V        SET      #(V~=Q&V>7,V,Q)
 ERROR,0,EOASINDX&NOADINDX&(V=0|V>7) QMM
 ERROR,0,A1A&#(TCOR(P(#AD),S:INT),,P(#AD)=V)&V>0&(EOASINDX&NOADINDX) QMG
 ERROR,0,(P(#BI)=0|Q1=0|Q1>7)  QMI
        GEN,#(EOASINDX&NOADINDX,,SPI)     AI,V,(A1A*AN)**OS+I
         GEN,SO   NOADINDX*A1A,OP,C2,#(NOADINDX,P(#AD),V),#(NOADINDX;
                  ,AN,P(#AD)+NAFA*AN)
 GOTO,ANS=0|P(#AL)&LJIHWD LLNG
         GEN,SP  SH,C2,,#(P(#AL),;
 #((ANS<M32&ANS>M12)*(Y1~=0|OP=LH),ANS,ANS&WM|CIR),ANS+(ANS>20)*CM12)
LLNG     SET      #(P(#AL)|ANDSKIP,L(1**LNG-1),)
 GOTO,GENAND=0 %P
 GEN,SP #(P(#AL),AND,SH),C2,,#(P(#AL),LLNG,(LNG-WL+HL*LJIHWD)&SHM|ARTH)
%P       BOUND    1
         GEN,#(V=Q1,,SP) LW,Q,,%S
%PEND    PEND
 FIN
         SPACE     5
*
 CLOSE AX,NEO,M12,CM12,M32,R#,;
 A1A,AF2V,%GENC,F,I,LA,R,V,Y1,Y2,LJIHWD,GENAND,ANDSKIP,SHFSKIP,@ERRGET
 CLOSE FETCH%PLAIN%K%X8%X16,FETCH%X4,FETCH%X64,FETCH%EO%AD,WORD%JXXX
 CLOSE SET%VARIABLES,FETCH%WORD,JXXX%SERIES,%P,EMAN
         PAGE
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 OPEN  APE,B,BX,C23,ENV,L32,PERF,POS,PS
 OPEN AIQEOVAL,C23#,CX#,ANS#,S#,%EV#,OP#,CX2#,S1GSP4#,S2GSP2I#,S3GSP#,;
 S4GSP#,S5GSPI#,S5GOP#,S5GREG#,S6GSP#,S7GSP#,S8GSPI#,;
 S9GSP#,S10GSO#,S11GOP#,S12GSO#,S13GSP#,S14GSPI#,S15GSP#,S16GSP#
*PASS SET S:UFV(PASS)+1  THE REAL PASS SWITCH IS SET LIKE THIS EARLIER.
*
* THE FOLLOWING CHOICE LISTS ARE SET OUTSIDE, BUT USED INSIDE THE PROC.
C23#     SET      C2+1,CX
CX#      SET      (C2+1)*(C2<7)*PERF,C3
ANS#     SET      ,HL*(S=0),(3*BL,2*BL,1*BL,)
S#       SET      ,PFB+Q2=HL,(PFB+Q2)**-3
%EV#     SET      ,PBI=WL,PBI=HL|(PBI=WL)*2
OP#      SET      (LW,LBY,LH),(LW,LH,LBY)
CX2#     SET      CX,C23
S1GSP4#  SET      ,(SP4)
S2GSP2I# SET      ,(SP2I)
S3GSP#   SET      ,(SP)
S4GSP#   SET      ,(SP)
S5GSPI#  SET      ,(SPI)
S5GOP#   SET      LI,AI
S5GREG#  SET      (CX,Q),C23
S6GSP#   SET      (SP),
S7GSP#   SET      ,(SP)
S8GSPI#  SET      (SPI),
S9GSP#   SET      (SP),
S10GSO#  SET      ,(SO)
S11GOP#  SET      STS,OP||7
S12GSO#  SET      ,(SO)
S13GSP#  SET      ,(SP)
S14GSPI# SET      ,(SPI)
S15GSP#  SET      ,(SP)
S16GSP#  SET      (SP),
PFB,PBI,C2,C3,C23,CX,OP,PERF,Q,Q1,Q2,S SET 0
*
:PUT,:STORE    CNAME  1
:%PUT,:%STORE  CNAME  0
         PROC
NAFA     SET      AFA=0
P,ITEMLIST SET    AF(1)
PAD      SET      P(#AD)
PBI      SET      P(#BI)
PFB      SET      P(#FB)
Z        SET      P(#AL)
Q        SET      AF(2)
E        SET      NUM(Q)
Q1       SET      Q(1) POS.--EVEN THOUGH THE #EO ATTRIBUTE MAY BE NEG.
Q2       SET      Q(2)
C2       SET      CF(2)
C3       SET      CF(3)
X4       SET      E=1&PBI<BL
X64      SET      E=1&PBI>WL
D        SET      X4|X64
LNG      SET      (P(#LB)-PFB&WM)+1
PERF     SET      LNG=BL&((PFB+Q2)&7)=0|LNG=HL&((PFB+Q2)&15)=0|LNG=WL
ENV      SET      E=1&(PBI=BL|PBI=HL)&PERF=0
CX       SET      CX#((C3>0&C3<8|ENV)+1)
C23      SET      C23#((CX&1)+1)
OP       SET      OP#(PERF+1,((E=1)*(PBI**-3)*(PBI<WL)*(PERF=0)|(LNG=HL;
                  |(LNG=BL)*2)*PERF)+1)
OS       SET      OP**-5-1
POS      SET      (ENV|PERF)*OS
%EV      SET      %EV#(OS+1)
S        SET      S#(POS+1)
PS       SET      PERF*S
ANS      SET      (WM-P(#LB)-Q2-ANS#(OS+1,(S+1)*(OS=2)))&SHM
%S       SET      X4*(WL-P(#LB)-1)|(X4=0)*ANS
AN       SET      P(#EO)+Q1*(E=2)
EOASINDX SET      (AFA*AN=0&PS=0)=0
NOADINDX SET      (AFA&#(TCOR(PAD,S:INT),,PAD>0&PAD<8)&(OP=LW|PERF=0)&;
                  E~=1)=0
AIQEOVAL SET      EOASINDX&NOADINDX&(X4|ENV)
B        SET      E=1&PERF&(LNG=BL&(PBI=HL|PBI=WL)|LNG=HL&PBI=WL)
BX       SET      B&(EOASINDX|%EV>0)
APE      SET      PAD+NAFA*AN
LF(1)    RES      0
*
 GOTO,(PASS=2)+(PASS=2&D=0) %P2,NO%X4X64
L32      SET      #(X4,,L(X'1F'))
 RES X4*5+X64*2+BX+(B&%EV>0)+(EOASINDX&NOADINDX)+((E~=1|D|EOASINDX=0|;
                  BX)=0)
CX       SET      CX2#((X64&CX~=C23&C23<8&PERF)+1)
 RES (X64&C23~=CX)+(PERF=0)+((ANS=0&X4=0|PERF)=0)
LLNG     SET      #(PERF|LNG<20,L(1**LNG-1),)
LF(2) RES ENV+1+ENV+AIQEOVAL+X4+(X4&NAME)+((NAME=0|X4=0&ANS=0|PERF)=0)
 GOTO %PEND
*
%P2      BOUND    1
         GEN,S1GSP4#(X4+1) LW,CX,,Q,SH,CX,,PBI**-1,;
                  AND,CX,,#(X4,,L(X'1F')),LCW,CX,,CX
         GEN,S2GSP2I#(X64+1)     LW,C23,,Q,MI,C23,PBI**(-5+POS)
NO%X4X64 ERROR,0,X64&(C23&1)=0|C2&1&PERF=0 QMD
 ERROR,0,NUM(P)~=NIE QMA
         GEN,S3GSP#(BX+1)   LW,CX,,Q
         GEN,S4GSP#((B&%EV>0)+1) SH,CX,,%EV
 ERROR,0,C2>15|C3>7|E=1&Q1>7|C3=0&AFA&(EOASINDX&NOADINDX|D)&(PERF=0;
 |C2>6) QMH
 ERROR,0,E=1&(Q1=C2|Q1=C3|Q1=C2+1)|C3=C2|C3=C2+1 QMO
         GEN,S5GSPI#((EOASINDX&NOADINDX)+1) S5GOP#((D|ENV|BX)+1),;
                   S5GREG#(X64+1,(X64=0)*(X4|ENV)+1),((AFA*AN)**POS+PS);
                   **(X4*(5-PBI**-1))
         GEN,S5GSPI#(X4+1)  SH,Q1,(PBI**-1-5)&SHM|CIR
         GEN,S6GSP#((E~=1|D|EOASINDX=0|BX)+1) AW,CX,,Q
CX       SET      CX2#((X64&CX~=C23&C23<8&PERF)+1)
 ERROR,0,CX=0&(NOADINDX&(EOASINDX|X64|BX)|X4&PERF=0)     QMF
         GEN,S7GSP#((X64&C23~=CX)+1) LW,CX,,C23
         GEN,S8GSPI#(PERF+1) #(PERF|LNG<20,(LW,C2+1,L(1**LNG-1)),(LI,C2;
                             +1,1**LNG-1))
         GEN,S9GSP#((ANS=0&X4=0|PERF)+1) SH,C2,CX*X4,%S&SHM|DBL
LF(2)    GEN,S10GSO#(ENV+1)   AFA,OP,CX,Q1,APE
 ERROR,0,E=1&(PBI=0|Q1=0|Q1>7)     QMI
 ERROR,0,AFA&#(TCOR(PAD,S:INT),,PAD=C2|(PAD=C23)*X64|PAD=CX|(PAD=C3)*;
 NUM(CF(3))) QMG
         GEN,SO   (ENV=0&NOADINDX)*AFA,S11GOP#(PERF+1),C2,#(X4|ENV;
 |E=1&X64=0&BX=0&(EOASINDX&NOADINDX)=0,#(BX|X64|EOASINDX&NOADINDX,;
 #(NOADINDX,PAD),CX),Q1),ENV*CX+(NOADINDX=0)*AN+#(ENV=0&NOADINDX,,APE)
         GEN,S12GSO#(ENV+1)   AFA,OP||7,CX,Q,APE
         GEN,S13GSP#(X4+1)   SH,Q,,(5-PBI**-1)&SHM|CIR
   GEN,S14GSPI#(AIQEOVAL+1) AI,Q,-(((AFA*AN)**POS+PS)**(X4*(5-PBI**-1)))
 GOTO,NAME=0 %PEND
         GEN,S15GSP#(X4+1)    LCW,CX,,CX
         GEN,S16GSP#((X4=0&ANS=0|PERF)+1) SH,C2,CX*X4,-%S&SHM|DBL|Z*ARTH
LOC%NEXT SET      %
%PEND    PEND
*
 CLOSE AIQEOVAL,C23#,CX#,ANS#,S#,%EV#,OP#,CX2#,S1GSP4#,S2GSP2I#,S3GSP#,;
 S4GSP#,S5GSPI#,S5GOP#,S5GREG#,S6GSP#,S7GSP#,S8GSPI#,;
 S9GSP#,S10GSO#,S11GOP#,S12GSO#,S13GSP#,S14GSPI#,S15GSP#,S16GSP#
 CLOSE APE,B,BX,C23,ENV,L32,PERF,POS,PS
 CLOSE N,E,D,%EV,AN,S,%S,ANS,LNG,LLNG,P,Q,Q1,Q2,X4,X64,Z
 CLOSE NO%X4X64,PAD,PBI,PFB,NAFA,%P2
 CLOSE NOADINDX,EOASINDX,C2,C3,CX,OP,OS,LOC%NEXT
         CLOSE    FLAGS
 CLOSE #FB,#LB,#AD,#BI,#EO,#SF,#AL,#ST,#NENT,ITEMLIST,#,PASS
         CLOSE    ERRMSSG
 CLOSE QMA,QMB,QMC,QMD,QME,QMF,QMG,QMH,QMI,QMJ,QMK,QML,QMM,QMN,QMO
 CLOSE NIE,SO,SP,SPI,SP2I,SP4
 CLOSE ARTH,CIR,DBL,SHM,WL,#BYTESPERWL,WM,HL,BL
 CLOSE AI,CI,LI,MI,SH,AW,CW,LW,STW,LCW,CS,XW,STS,OR,AND,LH,STH,BCR,BCS
 CLOSE LBY,STB,ANLZ,MBS
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*        CDISP    :ENTRY%TEMPLATE,:TABLE%SET,:TABLE%DATA
         END
