         TITLE    'OPR-B00,08/22/73,DWG702985'
         PAGE
*
*
*  E X T E R N A L    C O M M U N I C A T I O N
*
*
*  DEFINITIONS
*
         DEF      BALCOMP           'BAL,LX FFCOMPAR' INSTRUCTION
         DEF      BASEADR           BASE ADR FOR SHORT ADR OFFSETS
         DEF      CHAREQ            CHARACTER EQUAL/NOT EQUAL
         DEF      COMPINST          COMPARE INST TABLE
         DEF      CONVTABL          TYPE CONVERSION CODE TABLE
         DEF      DIVZERO           DIVIDE BY ZERO TRAP ROUTINE
         DEF      DTYPEF            DYACIC FLOT TYPE SETUP
         DEF      DTYPEIF           INTG/FLOT TYPE SETUP
         DEF      DTYPEIF1            * (ALT. ENTRY)
         DEF      DTYPEIF2            * (ALT. ENTRY)
         DEF      DXDRIVER          DYADIC EXECUTION DRIVER
         DEF      DXTABLE           DYADIC OP ROUTINE ENTRY TABLE
         DEF      EXECUTE           EXECUTE XSEG
         DEF      FLOTINF           FLOATING POINT INFINITY
         DEF      FLOT0             FLOATING POINT 0.0
         DEF      FLOT01            FLOATING POINT 0.0, 1.0
         DEF      FLOT1             FLOATING POINT 1.0
         DEF      FLOT2             FLOATING POINT 2.0
         DEF      GENLOAD           GEN LOAD BY RSTYPE
         DEF      GENLOADT          GEN LOAD TO TEMP
         DEF      GXSEGDL1          GEN DYADIC LOAD (ALT. ENTRY)
         DEF      GXSEGINI          GEN XSEG INITIALIZATION
         DEF      GXSEGML           GEN MONADIC LOAD
         DEF      GXSTEXC1          GEN STORE/EXECUTE (ALT. ENTRY)
         DEF      GXSTEXEC          GEN XSEG STORE; EXECUTE XSEG
         DEF      INTGOVFL          INTEGER OVERFLOW (DOMAIN CHANGE)
         DEF      LFADR             LEFT ARG ADDRESS
         DEF      LFLGLADR          LEFT LOGICAL ADDRESS
         DEF      LFLGLCNT          LEFT LOGICAL BIT COUNT
         DEF      LFRANK            LEFT ARG RANK
         DEF      LFSIZE            LEFT ARG SIZE
         DEF      LFTEMP            LEFT ARG VALUE TEMP
         DEF      LFTYPE            LEFT ARG TYPE
         DEF      LOADINST          LOAD INSTRUCTION TABLE, BY TYPE
         DEF      LODBINST          LOAD 2ND ACCUM INST TABLE
         DEF      LOOPLOC           LOOP LOCATION
         DEF      MNOP              MONADIC NO OP ROUTINE
         DEF      MTYPEF            MONADIC FLOT TYPE SETUP
         DEF      MXDRIVER          MONADIC EXECUTION DRIVER
         DEF      OPR@             START OF PROCEDURE
         DEF      RSADR             RESULT ADDRESS
         DEF      RSRANK            RESULT RANK
         DEF      RSSIZE            RESULT SIZE
         DEF      RSTYPE            RESULT TYPE
         DEF      RTADR             RIGHT ARG ADDRESS
         DEF      RTRANK            RIGHT ARG RANK
         DEF      RTSIZE            RIGHT ARG SIZE
         DEF      RTTEMP            RIGHT ARG VALUE TEMP
         DEF      RTTYPE            RIGHT ARG TYPE
         DEF      SETADR            SET UP ARG ADR CELL
         DEF      SETADRS1          SET UP ADDRESS(ES), SEQUENTIAL
         DEF      STCCSEQ           STORE CC CODE SEQ
         DEF      STMPINST          STORE IN TEMP INST TABLE
         DEF      STORINST          STORE INSTRUCTION TABLE
         DEF      TYPETEMP          TYPE TEMP                           U08-0004
*
*  REFERENCES
*
         REF      ALOCHNW           ALLOCATE HEADER AND N WORDS
         REF      ALOCRS            ALLOCATE RESULT DATA BLOCK
         REF      BITMASK           LOGICAL BIT SELECTION TABLE
         REF      CIRCULAR          CIRCULAR FUNCTION EVAL
         REF      CLOADLNK          DERAIL LINK FOR GXSEGDL
         REF      COPTRIG           COMPOSITE OP TRIGGER
         REF      CSETLNK           DERAIL LINK FOR DSETUP
         REF      CSTORLNK          DERAIL LINK FOR GXSTEXEC
         REF      CTYPELNK          DERAIL LINK FOR DTYPEIF
         REF      DCATEN            DYADIC CATENATE OP ROUTINE
         REF      DCOMPRES          DYADIC COMPRESS OP ROUTINE
         REF      DDEAL             DYADIC DEAL OP ROUTINE
         REF      DDECODE           DYADIC DECODE OP ROUTINE
         REF      DDROP             DYADIC DROP OP ROUTINE
         REF      DENCODE           DYADIC ENCODE OP ROUTINE
         REF      DEXPAND           DYADIC EXPAND OP ROUTINE
         REF      DINDEXOF          DYADIC INDEX-OF OP ROUTINE
         REF      DMATDIV           DYADIC MATRIX DIVIDE OP ROUTINE
         REF      DMEMBER           DYADIC MEMBERSHIP OP ROUTINE
         REF      DREF              DE-REF
         REF      DRESHAPE          DYADIC RESHAPE OP ROUTINE
         REF      DROTATE           DYADIC ROTATE OP ROUTINE
         REF      DTAKE             DYADIC TAKE OP ROUTINE
         REF      DTBAR             DYADIC T-BAR OP ROUTINE
         REF      DTRANS            DYADIC TRANSPOSE ROUTINE
         REF      DXRETURN          DYADIC EXECUTION DRIVER RETURN
         REF      ERDOMAIN          DOMAIN ERROR
         REF      ERLENGTH          LENGTH ERROR
         REF      ERRANK            RANK ERROR
         REF      ERSYN             SYNTAX ERROR HANDLER
         REF      FCEILING          F CEILING EVAL
         REF      FEXP              F EXPONENTIAL EVAL
         REF      FFACT             F FACTORIAL EVAL
         REF      FFCOMB            F COMBINATORIAL EVAL
         REF      FFCOMPAR          F COMPARISON EVAL
         REF      FFLOG             F DYADIC LOG EVAL
         REF      FFLOOR            F FLOOR EVAL
         REF      FFPOWER           F POWER EVAL
         REF      FFRESIDU          F RESIDUE EVAL
         REF      FIPOWER           F TO I POWER EVAL
         REF      FLOG              F MONADIC LOG EVAL
         REF      FSQRT             F SQUARE ROOT EVAL
         REF      F2I               CONVERT F TO I
         REF      ICEILING          I CEILING EVAL
         REF      IFACT             I FACTORIAL EVAL
         REF      IFLOOR            I FLOOR EVAL
         REF      IICOMB            I COMBINATORIAL EVAL
         REF      IIPOWER           I POWER EVAL
         REF      IIRESIDU          I RESIDUE EVAL
         REF      IROLL             I ROLL EVAL
         REF      LFARG             LEFT ARG PNTR
         REF      MDIMEN            MONADIC DIMENSION OP ROUTINE
         REF      MGRADEDN          MONADIC GRADE DOWN OP ROUTINE
         REF      MGRADEUP          MONADIC GRADE UP OP ROUTINE
         REF      MIBEAM            MONADIC I-BEAM OP ROUTINE
         REF      MINDEX            MONADIC INDEX GENERATOR OP ROUTINE
         REF      MMATINV           MONADIC MATRIX INVERT OP ROUTINE
         REF      MRAVEL            MONADIC RAVEL OP ROUTINE
         REF      MREVERSE          MONADIC REVERSE OP ROUTINE
         REF      MTBAR             MONADIC T-BAR OP ROUTINE
         REF      MTRANS            MONADIC TRANSPOSE OP ROUTINE
         REF      MXRETURN          MONADIC EXECUTION DRIVER RETURN
         REF      OPBREAK           OP BREAK HANDLER
         REF      OPER              OPERATOR WORDS
         REF      OPRTEMPS          TEMPS ARE IN WINDOW IN APLUTSI      U08-0006
         REF      RESULT            RESULT PNTR
         REF      RETURN            RETURN ADR CELL
         REF      RTARG             RIGHT ARG PNTR
         REF      SYSTERR           SYSTEM ERROR
         REF      XSEGBASE          XSEG BASE
         REF      XSEGBRK           XSEG BREAK FLAG
         PAGE
*
*
*  A S S E M B L Y    P A R A M E T E R S
*
*
         SYSTEM   SIG5F
PROGSECT CSECT    1
OPR@     RES      0                START OF PROCEDURE
BASEADR  EQU      %                 BASE ADR FOR SHORT ADR OFFSETS
*
*  REGISTERS
*
IX       EQU      0                 INTERPRET REG PAIR
IX1      EQU      1                     *
N        EQU      1                 XSEG EXECUTION-TIME INDEX
X        EQU      1                 GENERAL INDEX REG
T        EQU      2                 TYPE
XL       EQU      3                 XSEG LOC
A        EQU      4                 ARG ADR/INDEX
LX       EQU      5                 INDEX LINK REG
LX7      EQU      7                 INDEX LINK REG
OP       EQU      6                 OP CODE INDEX
AI       EQU      7                 ACCUM FOR LOGL/CHAR/INTG VALUES
AF       EQU      6                 ACCUM FOR FLOT VALUES
AF1      EQU      7                     *
BI       EQU      9                 2ND ACCUM FOR LOGL/CHAR/INTG VALUES
BF       EQU      8                 2ND ACCUM FOR FLOT VALUES
BF1      EQU      9                     *
BUF      EQU      7                 BUFFER FOR MOVING DATA/CODE GROUPS
R        EQU      8                 GENERAL WORK REG
S        EQU      11                SIZE
L3       EQU      12                LINK REG
L2       EQU      13                LINK REG
L1       EQU      14                LINK REG
*
*  ARG TYPE CODES
*
WORDLOGL EQU      0                 WORD LOGICAL (WORD)
LOGL     EQU      1                 LOGICAL (BIT)
CHAR     EQU      2                 CHARACTER (BYTE)
INTG     EQU      3                 INTEGER (WORD)
FLOT     EQU      4                 FLOATING (DOUBLEWORD)
ISEQ     EQU      5                 INDEX SEQUENCE VECTOR
LIST     EQU      6                 LIST
*
*  CODESTRING DESIGNATIONS
*
MOPLOW   EQU      50                MONADIC OPS: LOW END
MOPROLL  EQU      51                MONADIC ROLL
MOPEXP   EQU      65                MONADIC EXPONENTIAL
MOPCEIL  EQU      68                MONADIC CEILING
MOPABS   EQU      70                MONADIC ABSOLUTE VALUE
MOPFACT  EQU      71                MONADIC FACTORIAL
DOPLOW   EQU      80                DYADIC OPS: LOW END
DOPADD   EQU      91                DYADIC ADD
DOPMUL   EQU      93                DYADIC MULTIPLY
DOPDIV   EQU      94                DYADIC DIVIDE
DOPPOWER EQU      95                DYADIC POWER
DOPMAX   EQU      98                DYADIC MAXIMUM
DOPRESID EQU      100               DYADIC RESIDUE
DOPLESS  EQU      102               DYADIC LESS
DOPNEQ   EQU      106               DYADIC NOT EQUAL
DOPAND   EQU      108               DYADIC AND
DOPNAND  EQU      110               DYADIC NAND
         PAGE
*
*
*  P R O C S
*
*
TLOC     SET      0                                                     U08-0008
*
TEMP     CNAME    1
DTEMP    CNAME    2
         PROC
         DO1      NAME=2
TLOC     SET      TLOC+(TLOC&1)                                         U08-0011
         DISP     TLOC                                                  U08-0012
LF       EQU      OPRTEMPS+TLOC                                         U08-0013
TLOC     SET      TLOC+NAME                                             U08-0014
         PEND
*
*
EVEN     CNAME    0
ODD      CNAME    1
         PROC
LF       EQU      %
         ERROR,1,(CF(2)+NAME)&1   'REGISTER HAS WRONG PARITY'
         PEND
*
*
EQUAL    CNAME
         PROC
LF       EQU      %
         ERROR,1,1-(CF(2)=CF(3))  'REGISTERS MUST BE EQUAL'
         PEND
*
*
EXCHANGE CNAME
         OPEN     I,K,GROUP
GROUP    EQU      LFARG,LFTYPE,LFSIZE,LFRANK,LFADR
         PROC
LF       EQU      %
I        DO       NUM(AF)
K        SET      SCOR(AF(I),ARGS,TYPES,SIZES,RANKS,ADRS)
         ERROR,1,K=0                'UNKNOWN GROUP INDICATOR'
         LW,R     GROUP(K)
         XW,R     GROUP(K)+1
         STW,R    GROUP(K)
         FIN
         PEND
         CLOSE    I,K,GROUP
*
*
NB       CNAME    X'680'
NBGE     CNAME    X'681'
NBLE     CNAME    X'682'
NBE      CNAME    X'683'
NBL      CNAME    X'691'
NBG      CNAME    X'692'
NBNE     CNAME    X'693'
         PROC
         ERROR,1,(AF>=0)+(NUM(AF)>1)  'AF MUST BE NEG CONST ADR'
LF       GEN,12,20  NAME-1,AF
         PEND
         PAGE
*
*
*  XSEG GEN PROCS
*
*
CODE     CNAME
         PROC
         DO       CF(2)>0
LF       GEN,4,12,16  CF(2),CF(2),AF(1)-BASEADR
         ELSE
LF       GEN,32   0
         FIN
         PEND
*
*
GENX     CNAME
         PROC
LF       INT,IX   AF
         BCR,15   %+4
         LM,BUF   BASEADR,IX1
         STM,BUF  0,XL
         AW,XL    IX
         PEND
*
*
         OPEN     GEN
GEN      CNAME
         OPEN     M,N,MN,I
         PROC
LF       EQU      %
         ERROR,1,1-(NUM(CF)=3)  'WRONG NUMBER OF CF ARGS'
M        SET      CF(2)
N        SET      CF(3)
MN       SET      M+N
         ERROR,1,1-(NUM(AF)=(M>0)+(N>0)) 'WRONG NUMBER OF AF ARGS'
         DO       M>0
I          DO       N
             LW,AF(1)+M+I-1  AF(2)+I-1
           FIN
I          DO       MN*(MN<3)
             STW,AF(1)+I-1   I-1,XL
           ELSE
             LCI         MN
             STM,AF(1)   0,XL
           FIN
         ELSE
I          DO       MN*(MN<3)
             LW,BUF      AF(1)+I-1
             STW,BUF     I-1,XL
           ELSE
             LCI         N
             LM,BUF      AF(1)
             STM,BUF     0,XL
           FIN
         FIN
         AI,XL    MN
         PEND
         CLOSE    M,N,MN,I
         PAGE
*
*
*  TABLE BUILDING PROCS
*
*
TABLE    CNAME
         OPEN     T,N
         PROC
T        SET      %-AF(1)
LF       EQU      T
         DISP     T
         PEND
*
*
ITEM     CNAME
         PROC
N        SET      T+AF(1)-%
         ERROR,1,N<0           'ITEM OUT OF SEQUENCE'
         RES      N*(N>0)
         DISP     AF(1)
         PEND
         CLOSE    T,N
         PAGE
*
*
*  O P E R A T O R    E X E C U T I O N    D R I V E R S
*
*
         USECT    PROGSECT
*
*
*  MONADIC EXECUTION DRIVER
*
*              ENTERED WITH OPTYPE IN 'OP' REGISTER, AND THE ARG
*              POINTER IN RTARG.  IF NO ERRORS OCCUR, IT RETURNS
*              TO 'MXRETURN' WITH THE RESULT POINTER IN 'RESULT'.
*              ERRORS LEAD TO ERDOMAIN, ERRANK, OR ERLENGTH.
*
*
MXDRIVER EQU      %                 MONADIC EXECUTION DRIVER
         LI,A     MXRETURN          SET UP RETURN ADR
         STW,A    RETURN
         CI,OP    DOPLOW            CHECK OP RANGE
         BL       MXTABLE,OP        LOW: GO DIRECTY INTO JUMP TABLE
         AI,OP    MOPLOW-DOPLOW     HIGH: SHIFT TO LOWER RANGE FIRST
         STW,OP   OPER              SAVE MODIFIED OP (FOR 'INTGOVFL')
         B        MXTABLE,OP
*
MXTABLE  TABLE    MOPLOW            MONADIC OP JUMP TABLE
         B        MMATINV           MONADIC MATRIX INVERT
         B        MROLL             MONADIC ROLL
         B        MTBAR             MONADIC TYPE CONVERSION
         B        ERSYN             UNUSED (REDUCTION, 1ST COORD)
         B        ERSYN             UNUSED (REDUCTION)
         B        MINDEX            MONADIC INDEX GENERATOR
         B        MDIMEN            MONADIC DIMENSION
         B        MRAVEL            MONADIC RAVEL
         AI,OP    1                 MONADIC REVERSE (1ST COORD)
         B        MREVERSE          MONADIC REVERSE
         B        MTRANS            MONADIC TRANSPOSE
         B        MNOP              MONADIC PLUS
         B        MMINUS            MONADIC MINUS
         B        MSIGNUM           MONADIC SIGNUM
         B        MRECIP            MONADIC RECIPROCAL
         B        MEXP              MONADIC EXPONENTIAL
         B        MLOG              MONADIC LOGARITHM
         B        MPITIMES          MONADIC PI TIMES
         B        MCEILING          MONADIC CEILING
         B        MFLOOR            MONADIC FLOOR
         B        MABS              MONADIC ABSOLUTE VALUE
         B        MFACT             MONADIC FACTORIAL
         BAL,15   SYSTERR           UNUSED
         BAL,15   SYSTERR           UNUSED
         B        MIBEAM            MONADIC I-BEAM
         B        MGRADEUP          MONADIC GRADE UP
         B        MGRADEDN          MONADIC GRADE DOWN
         B        MCOMPL            MONADIC COMPLEMENT
         BAL,15   SYSTERR           UNUSED
         BAL,15   SYSTERR           UNUSED
         PAGE
*
*
*  DYADIC OPERATOR EXECUTION DRIVER
*
*              ENTERED WITH OPTYPE IN 'OP' REGISTER, AND THE ARG
*              POINTERS IN LFARG AND RTARG.  IF NO ERRORS OCCUR,
*              IT RETURNS TO 'DXRETURN' WITH THE RESULT POINTER
*              IN 'RESULT'.  ERRORS LEAD TO ERDOMAIN, ERRANK, OR
*              ERLENGTH.
*
*
DXDRIVER LI,A     DXRETURN          SET UP RETURN ADDRESS
         STW,A    RETURN
         B        DXTABLE,OP        BRANCH TO APPROPRIATE OP ROUTINE
*
DXTABLE  TABLE    DOPLOW            DYADIC OP JUMP TABLE
         B        DMATDIV           DYADIC MATRIX DIVIDE
         B        DDEAL             DYADIC DEAL
         B        DTBAR             DYADIC TYPE CONVERSION
         AI,OP    1                 DYADIC COMPRESSION (1ST COORD)
         B        DCOMPRES          DYADIC COMPRESSION
         B        DINDEXOF          DYADIC INDEX OF
         B        DRESHAPE          DYADIC RESHAPE
         B        DCATEN            DYADIC CATENATE/LAMINATE
         AI,OP    1                 DYADIC ROTATE (1ST COORD)
         B        DROTATE           DYADIC ROTATE
         B        DTRANS            DYADIC TRANSPOSE
         B        DADD              DYADIC ADD
         B        DSUB              DYADIC SUBTRACT
         B        DMUL              DYADIC MULTIPLY
         B        DDIV              DYADIC DIVIDE
         B        DPOWER            DYADIC POWER
         B        DLOG              DYADIC LOGARITHM
         B        DCIRC             DYADIC CIRCULAR
         B        DMAXIMUM          DYADIC MAXIMUM
         B        DMINIMUM          DYADIC MINIMUM
         B        DRESIDUE          DYADIC RESIDUE
         B        DCOMB             DYADIC COMBINATORIAL
         B        DLESS             DYADIC LESS
         B        DLESSEQ           DYADIC LESS OR EQUAL
         B        DGREAT            DYADIC GREATER
         B        DGREATEQ          DYADIC GREATER OR EQUAL
         B        DNEQUAL           DYADIC NOT EQUAL
         B        DEQUAL            DYADIC EQUAL
         B        DAND              DYADIC AND
         B        DOR               DYADIC OR
         B        DNAND             DYADIC NAND
         B        DNOR              DYADIC NOR
         BAL,15   SYSTERR           UNUSED
         BAL,15   SYSTERR           UNUSED
         B        DDECODE           DYADIC DECODE
         B        DENCODE           DYADIC ENCODE
         B        DTAKE             DYADIC TAKE
         B        DDROP             DYADIC DROP
         AI,OP    1                 DYADIC EXPAND (1ST COORD)
         B        DEXPAND           DYADIC EXPAND
         B        DMEMBER           DYADIC MEMBERSHIP
*
*
*  MONADIC NO-OP ROUTINE (RESULT = ARG)
*
MNOP     EQU      %
         LW,A     RTARG             GET RIGHT ARG PNTR
         MTW,1    1,A               BUMP ITS REF COUNT
         STW,A    RESULT            STORE AS RESULT PNTR
         B       *RETURN            RETURN
         PAGE
*
*
*  M O N A D I C    S C A L A R    O P    R O U T I N E S
*
*
MMINUS   EQU      %                 MONADIC MINUS
         LI,T     ISEQ              IS ARG AN ISEQ ?
         CB,T    *RTARG
         BNE      16Z1              NO, HANDLE NORMALLY
         BAL,XL   BILDISEQ          YES, BUILD ISEQ RESULT
         LI,OP    DOPMUL+1          SET OP CODE TO FALL INTO
*                                     RANGE OF ISEQ TABLES
*                                   (RETURNS IF ISEQOVFL).
16Z1     LI,OP    MOPABS+1          FIX OP TO FALL INTO ABS/NEG RANGE
*
MABS     EQU      %                 MONADIC ABSOLUTE VALUE
         BAL,LX   MTYPEIF           ALLOW NUMERIC ARG; RESULT = I/F
         AI,OP    -2                INTG: MODIFY OP
         BAL,L2   MSETUP            FLOT; SET UP ADDRESSES
         BAL,L1   GXSEGML           GEN INIT XSEG CODE
         LW,IX    MOPTBL2,OP        GEN LOAD MINUS/ABS OF ARG
         BAL,LX   CHANGOP
         CI,OP    MOPABS            IF IT'S INTG,
         BL       GXOVSTEX          GEN  OVFL TEST CODE
         B        GXSTEXEC          GEN STORE, ETC.
*
*
MOPTBL2  TABLE    MOPABS-2          I/F  MINUS/ABS TABLE
         LAW,AI   AI                I ABS
         LCW,AI   AI                I MINUS
         LAD,AF   AF                F ABS
         LCD,AF   AF                F MINUS
         PAGE
*
*
MEXP     EQU      %                 MONADIC EXPONENTIAL
MLOG     EQU      %                 MONADIC LOGARITHM
MPITIMES EQU      %                 MONADIC PI TIMES
         BAL,L1   MTYPEF            SET UP TYPES; RESULT = FLOT
MONOP1   BAL,L2   MSETUP            SET UP ADDRESSES
         BAL,L1   GXSEGML           GEN LOAD/CONVERT
         LW,R     MOPTBL3,OP        GEN BAL TO EVAL ROUTINE
         GEN,1,0  R
         B        GXSTEXEC          GEN STORE, ETC.
*
*
MOPTBL3  TABLE    MOPEXP
         BAL,LX   FEXP              F EXP
         BAL,LX   FLOG              F LOG
         FML,AF   FLOTPI            PI TIMES
         BAL,L1   FCEILING          F CEILING
         BAL,LX   FFLOOR            F FLOOR
         BAL,LX   IFACT             I FACTORIAL
         BAL,LX   FFACT             F FACTORIAL
         BAL,LX   IROLL             I ROLL
*
*
MROLL    EQU      %                 MONADIC ROLL
         BAL,L1   MTYPEI            SET UP TYPES, RESULT = INTG
         AI,OP    MOPFACT+1-MOPROLL MODIFY OP (TO SHARE OP TABLE)
         B        MONOP1            HENCEFORTH, TREAT LIKE 'EXP', ETC.
*
*
MFACT    EQU      %                 MONADIC FACTORIAL
         BAL,LX   MTYPEIF           SET UP TYPES, RESULT = INTG/FLOT
         BDR,OP   MONOP1            INTG: MODIFY OP, FINISH LIKE EXP
         B        MONOP1            FLOT: FINISH LIKE EXP
         PAGE
*
*
MSIGNUM  EQU      %                 MONADIC SIGNUM
         LI,T     LOGL              IF ARG IS LOGL,
         CB,T    *RTARG               SIGNUM(ARG) = ARG.
         BE       MNOP
         BAL,L1   MTYPEI            SET TYPES; RESULT = INTG
         BAL,L2   MSETUP            SET ADRS
         LW,T     RTTYPE            SET RSTYPE SO THAT ARG'S
         STW,T    RSTYPE              WONT BE CONVERTED.
         BAL,L1   GXSEGML           GEN LOAD
         GEN,0,5  SIGCODE           GEN SIGNUM CODE SEQUENCE
         AWM,XL   -2,XL             FILL IN BRANCH ADDRESSES
         AWM,XL   -4,XL
         AWM,XL   -5,XL
         LI,T     INTG              SET TO STORE BY SIGNUM'S
         STW,T    RSTYPE              RESULT TYPE (INTG).
         B        GXSTEXEC          GEN STORE, ETC.
*
*
SIGCODE  EQU      %                 SIGNUM CODE SEQUENCE
         NBG      -1      (%+4)     -5
         BEZ      0       (%+4)     -4
         LI,AI    -1                -3
         B        0       (%+2)     -2
         LI,AI    +1                -1
         PAGE
*
*
MRECIP   EQU      %                 MONADIC RECIPROCAL
         BAL,L1   MTYPEF            SET TYPES, RESULT = FLOT
         BAL,L2   MSETUP            SET ADDRESSES
         BAL,LX   GXSEGINI          GEN XSEG INIT CODE
         LI,T     FLOT              IF ARG IS NOT FLOT,
         CW,T     RTTYPE
         BE       15Z1
         LI,A     1                     LOAD/CONVERT IT,
         BAL,L2   GENLOADT              STORE IT IN TEMP.
15Z1     LD,R     RECIPINS          GEN:     LD,AF    =1.0
         AW,R+1   RTADR                      FDL,AF   ARG (OR TEMP)
         GEN,2,0  R
         B        GXSTEXEC          GEN STORE, ETC.
*
*
         BOUND    8
RECIPINS LD,AF    FLOT1             RECIPROCAL CODE SEQ
         FDL,AF   0
         PAGE
*
*
MFLOOR   EQU      %                 MONADIC FLOOR
MCEILING EQU      %                 MONADIC CEILING
         AW,OP    =X'80000000'      SET 1ST-TIME FLAG; 'INTGOVFL' WILL
*                                     RESTORE OP WITH THIS FLAG RESET.
         BAL,LX   MTYPEIF           SET TYPES, RESULT = INTG/FLOT
         B        MNOP              INTG (I/L): NO-OP (RESULT=ARG)
         AI,OP    0                 FLOT: IS THIS 1ST TIME ?
         BGEZ     MSETRT           NO,DO IT IN FL. DOMAIN
         MTW,INTG-FLOT  RSTYPE      YES, SET UP ADDRESSES FOR INTEGER
         BAL,L2   MSETUP              RESULT, AND ATTEMPT OPERATION
         BAL,LX   GXSEGINI
         LW,R     RTADR               IN INTG DOMAIN.
         AW,R     LOADINST+FLOT     LOAD IT (FLOT)
         LW,R+1   MOPTBL4,OP        GEN  BAL ICELING/IFLOOR
         GEN,2,0  R
         B        GXSTEXEC          GEN STORE, ETC.
MSETRT   STW,T    RTTYPE           SET RTTYPE TO FL.
         B        MONOP1
*
*
MOPTBL4  TABLE    MOPCEIL           INTG FLOOR/CEILING SEQ TABLE
         BAL,L1   ICEILING          I CEILING
         BAL,LX   IFLOOR            I FLOOR
         PAGE
*
*
MCOMPL   EQU      %                 MONADIC COMPLEMENT
         LI,T     LOGL              IF ARG IS LOGL, DO IT WORD-WISE
         CB,T    *RTARG
         BE       17Z1
         BAL,L1   MTYPEL            NOPE - SET UP TYPE, RESUL = LOGL
         B        17Z2                SET ADR AND DO IT BIT-WISE.
17Z1     STW,T    RSTYPE            WORDWISE: SET ARG TYPE  TO
         LI,T     WORDLOGL            'WORD LOGICAL' FOR ADDRESSING
         STW,T    RTTYPE              'EM 32 BITS AT A TIME.
17Z2     BAL,L2   MSETUP
         BAL,L1   GXSEGML           GEN BIT/WORD LOAD
         GEN,0,1  EORINST           GEN:     EOR,AI   =-1
         B        GXSTEXEC          GEN BIT/WORD STORE, ETC.
         PAGE
*
*
*  D Y A D I C    S C A L A R    O P    R O U T I N E S
*
*
DADD     EQU      %                 DYADIC ADD
DSUB     EQU      %                 DYADIC SUBTRACT
DMUL     EQU      %                 DYADIC MULTIPLY
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BLZ      NORMALOP            DON'T DO SPECIAL CASING.
         LI,T     ISEQ              IS LEFT ARG AN 'INDEX SEQUENCE' ?
         CB,T    *LFARG
         BNE      8Z2               NO, CHECK RIGHT ARG
         CB,T    *RTARG             YES, IS RIGHT ARG ALSO ISEQ ?
         BNE      8Z1               NO
         CI,OP    DOPMUL            YES, BOTH ARGS ARE ISEQ'S.  WE MAY
         BE       NORMALOP            ADD OR SUBTRACT THEM, BUT NOT MUL.
         BAL,XL   BILDISEQ          FORM RESULTANT ISEQ
         B        ISEQ1
         B        NORMALOP          OVFL: DO IT NORMALLY
8Z1      LH,R    *RTARG             LEFT ARG IS ISEQ.  IS RIGHT ARG     U08-0016
         CLM,R    LISCALAR            AN INTEGER OR LOGICAL SCALAR ?    U08-0017
         BCR,12   8Z3                                                   U08-0018
         BNE      NORMALOP          NO, DO NORMALLY                     U08-0019
8Z3      BAL,XL   BILDISEQ          YES, FORM RESULT ISEQ               U08-0020
         XW,X     T                 SWAP PTRS
         B        NORMALOP          OVFL: DO IT NORMALLY
8Z2      CB,T    *RTARG             LEFT ARG NOT ISEQ; IS RIGHT ARG ?
         BNE      NORMALOP          NO
         LH,R    *LFARG             YES, IS LEFT ARG AN INTEGER         U08-0022
         CLM,R    LISCALAR            OR LOGICAL SCALAR ?               U08-0023
         BCR,12   8Z4                                                   U08-0024
         BNE      NORMALOP          NO, DO NORMALLY                     U08-0025
8Z4      BAL,XL   BILDISEQ          YES, FORM RESULT ISEQ               U08-0026
         NOP                        DON'T SWAP ARG PTRS
*                                   OVFL: DO IT NORMALLY
*
*
NORMALOP EQU      %                 NORMAL ADD/SUB/MUL
         BAL,LX   DTYPEIF           ALLOW NUMERIC ARGS; RSTYPE= I/F
         AI,OP    -3                INTG: MODIFY OP
DYOP1    BAL,L2   DSETUP            EXAMINE ARG SHAPES; GET RS DATA BLOK
         BAL,L3   GXSEGDL           GEN 1ST PART OF XSEG: LOADS/CONVERTS
         AW,R     DOPTBL2,OP        IN-LINE: BUILD OP
         GEN,1,0  R                 GEN  'OP  RTADR'
         CI,OP    DOPADD            IF IT'S INTEGER,
         BL       GXOVSTEX            GEN OVERFLOW TEST CODE.
         B        GXSTEXEC
*
*
DDIV     EQU      %                 DYADIC DIVIDE
         BAL,L1   DTYPEF            ALLOW NUMERIC ARGS; RSTYPE= F
         B        DYOP1             CONTINUE AS FOR '+' ETC.
*
*
DOPTBL2  TABLE    DOPADD-3          ADD/SUB/MUL/DIV TABLE
         ODD,AI
         AW,AI    0                 I ADD
         SW,AI    0                 I SUBTRACT
         MW,AI    0                 I MULTIPLY
         FAL,AF   0                 F ADD
         FSL,AF   0                 F SUBTRACT
         FML,AF   0                 F MULTIPLY
         FDL,AF   0                 F DIVIDE
*                                                                       U08-0028
*                                                                       U08-0029
         BOUND    8                                                     U08-0030
LISCALAR DATA     LOGL**8+0,INTG**8+0    LOGICAL/INTEGER SCALAR HEADINGSU08-0031
         PAGE
*
*
DLOG     EQU      %                 DYADIC LOGARITHM
         BAL,L1   DTYPEF            ALLOW NUMERIC ARGS; RSTYPE= F
         B        DYOP2
*
*
DRESIDUE EQU      %                 DYADIC RESIDUE
DCOMB    EQU      %                 DYADIC COMBINATORIAL
DYOP5    BAL,LX   DTYPEIF           ALLOW NUMERIC ARGS; RSTYPE= I/F
DYOP6    AI,OP    -2                INTG: MODIFY OP INDEX
DYOP2    BAL,L2   DSETUP            SET UP SIZES, ADRS
DYOP7    BAL,L3   GXSEGDL           GEN LOAD LEFT, CONVERTS
         LW,T     RSTYPE
         AW,R     LODBINST,T        GEN LOAD RIGHT
         LW,R+1   DOPTBL3,OP
         GEN,2,0  R                           BAL,..  EVALUATOR
         B        GXSTEXEC          GEN STORE, ETC.
*
*
DOPTBL3  TABLE    DOPPOWER-2        I/F - POWER/LOG/RES/COMB TABLE
         BAL,LX   IIPOWER           I POWER
         ITEM     DOPPOWER
         BAL,LX   FFPOWER           F POWER
         BAL,LX   FFLOG             F LOG
         ITEM     DOPRESID-2
         BAL,LX   IIRESIDU          I RESIDUE
         BAL,LX   IICOMB            I COMBINATORIAL
         BAL,LX   FFRESIDU          F RESIDUE
         BAL,L1   FFCOMB            F COMBINATORIAL
         PAGE
*
*
DPOWER   EQU      %                 DYADIC POWER
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BLZ      DYOP5               DON'T DO SPECIAL CASING.
         LI,R     INTG**8+0         IS RIGHT ARG AN
         CH,R    *RTARG               INTEGER SCALAR  ?
         BE       12Z3              YES, SEE IF IT'S 2
         LI,R     FLOT**8+0         NO, IS IT A
         CH,R    *RTARG               FLOATING POINT SCALAR ?
         BE       12Z1              YES, SEE IF IT'S 2.0 OR 0.5
NORMPWR  BAL,LX   DTYPEIF           NO, CHECK TYPES; RSTYPE = I/F
         B        DYOP6             I*I: HANDLED LIKE I-COMB/RESIDUE
         BAL,L2   DSETUP            I*F, F*I, OR F*F: SET UP STUFF
         LI,T     FLOT
         CW,T     RTTYPE            CHECK RIGHT ARG TYPE
         BE       DYOP7             F*F OR I*F: TREAT LIKE F-COMB/RESID
         BAL,LX   GXSEGINI          F*I: GEN XSEG INIT CODE
         MTW,INTG-FLOT  RSTYPE
         LI,A     1                 GEN LOAD OF RIGHT ARG
         BAL,L1   GENLOAD             IN INTG DOMAIN
         LW,IX    LREGBI              TO REGISTER 'BI'.
         BAL,LX   CHANGREG
         MTW,FLOT-INTG  RSTYPE      GEN LOAD OF LEFT ARG
         LI,A     0                   IN FLOT DOMAIN
         BAL,L1   GENLOAD             TO REGISTERS 'AF/AF1'.
         GEN,0,1  FIPWRINS          GEN:     BAL,LX   FIPOWER
         B        GXSTEXEC          GEN STORE, ETC.
*
12Z1     LI,X     2                 RIGHT ARG = FLOT SCALAR
         LW,R    *RTARG,X           GET IT'S 1ST WORD
         CLM,R    PWRLIMS           IS IT 0.5 OR 2.0 ?
         BCR,12   12Z4              = 2.0,   SQUARE LFARG (FLOT)
         BCS,3    NORMPWR           NEITHER, DO NORMAL POWER
*                                   = 0.5,   SQUARE ROOT LFARG (FLOT)
         EXCHANGE ARGS              MAKE RTARG ACTIVE (LIKE MONADIC OPS)
         BAL,L1   MTYPEF            PRETEND IT'S A MONADIC 'SQRT' OP
12Z2     BAL,L2   MSETUP            CHECK TYPE, SET UP STUFF
         BAL,L1   GXSEGML           GEN LOAD/CONVERT
         LW,R     MOPTBL1,OP        GET SQUARE/SQRT INST
         GEN,1,0  R
         CI,OP    DOPPOWER-2        IF IT'S IN INTG DOMAIN,
         BE       GXOVSTEX            GEN  OVFL TEST CODE.
         B        GXSTEXEC          GEN STORE, ETC.
*
12Z3     LI,X     2                 RIGHT ARG IS AN INTG SCALAR
         CW,X    *RTARG,X           IS IT 2 ?
         BNE      NORMPWR           NO, DO NORMAL POWER
12Z4     EXCHANGE ARGS              = 2 (OR 2.0), TREAT LIKE A
         BAL,LX   MTYPEIF             MONADIC 'SQUARE' OP.
         AI,OP    -1                I*2: DECR OP BY 2
         BDR,OP   12Z2              F*2: DECR OP BY 1
*
*
MOPTBL1  TABLE    DOPPOWER-2        SQUARE/SQRT INST TABLE
         MW,AI    AI                I SQUARE
         FML,AF   AF                F SQUARE
         BAL,LX   FSQRT             F SQRT
*
*
         BOUND    8
PWRLIMS  DATA     FS'0.5',FS'2.0'   SPECIAL EXPONENT VALUES
*
FIPWRINS BAL,LX   FIPOWER           F TO I POWER INST
         PAGE
*
*
DCIRC    EQU      %                 DYADIC CIRCULAR
         BAL,L1   DTYPEF            CHECK TYPES; RESULT = FLOT TYPE
         BAL,L2   DSETUP            SET UP SIZES/ADRS
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BGEZ     20Z1                WE MUST GO THROUGH GXSEGDL
         BAL,L3   GXSEGDL             AND GEN CODE TO CONVERT LFARG
         GEN,0,3  CIRCSEQ1            FROM FLOT IN AF TO INTG IN T.
         LW,R     RTADR             GEN LOAD (FLOT) OF RT ARG
         AW,R     LOADINST+FLOT
         GEN,1,0  R
         B        20Z3
20Z1     BAL,LX   GXSEGINI          GEN XSEG INIT CODE
         MTW,INTG-FLOT  RSTYPE      GEN FETCH OF LEFT ARG
         LI,A     0
         BAL,L1   GENLOAD             IN INTG MODE.
         LW,IX    LREGTX
         BAL,LX   CHANGREG          MOVE IT TO 'TX' (IT'S SAFE THERE)
         LI,S     1
         CW,S     LFSIZE
         BNE      20Z2              IF LEFT ARG IS ONE ELEMENT,
         GEN,0,1  STORETX             SAVE LFARG OUTSIDE LOOP,
         STW,XL   LOOPLOC
         GEN,0,1  LOADTX              AND RESTORE IT INSIDE LOOP.
20Z2     EQU      %
         MTW,FLOT-INTG  RSTYPE      GEN LOAD OF RIGHT ARG
         LI,A     1
         BAL,L1   GENLOAD             IN FLOT MODE (REG 'AF/AF1')
20Z3     EQU      %
         GEN,0,3  CIRCSEQ           GEN RANGE CHECK, INDEXED BAL
         B        GXSTEXEC          GEN STORE, ETC.
*
*
TX       EQU      3              INDEX REG FOR 'CIRCULAR' BRANCH
*
CIRCSEQ  CLM,TX   CIRCLIMS          LEFT ARG RANGE CHECK
         BCS,9    ERDOMAIN
         BAL,LX   CIRCULAR,TX       INDEXED BAL INTO JUMP TABLE
*
CIRCSEQ1 BAL,LX   F2I               CONVERT LFARG VALUE TO INTG
         B        ERDOMAIN
         LW,TX    AI                  .. IN TX.
*
LOADTX   LW,TX    LFTEMP
STORETX  STW,TX   LFTEMP
*
         BOUND    8
CIRCLIMS DATA     -7,+7             LEFT ARG RANGE
         PAGE
*
*
DEQUAL   EQU      %                 DYADIC EQUAL
DNEQUAL  EQU      %                 DYADIC NOT EQUAL
*                                                                       U08-0033
*     SPECIAL CASE FOR CHARACTER ARGS                                   U08-0034
*                                                                       U08-0035
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BLZ      DYOP3               DON'T DO SPECIAL CASING.
         LI,T     CHAR
         CB,T    *LFARG             IF BOTH ARGS NUMERIC, TREAT LIKE
         BNE      19Z1                OTHER RELATIONALS.
         CB,T    *RTARG             IF BOTH ARGS CHARACTER,
         BNE      19Z2
CHAREQ   STW,T    LFTYPE            SET ALL TYPES = CHAR
         STW,T    RTTYPE
         STW,T    RSTYPE
         B        DYOP4
19Z1     CB,T    *RTARG
         BNE      DYOP8                                                 U08-0037
19Z2     LI,T     LOGL              TYPES MIXED,
         STW,T    RSTYPE              RESULT = ALL 0'S OR ALL 1'S.
         LI,T     WORDLOGL          (STORED 32 BITS AT A TIME,
         STW,T    LFTYPE              OF COURSE).
         STW,T    RTTYPE
         BAL,L2   DSETUP
         BAL,LX   GXSEGINI
         LW,R     DOPTBL7,OP
         GEN,1,0  R                 GEN LI,AI 0/1
         B        GXSTEXEC
*
*
DLESS    EQU      %                 DYADIC LESS
DGREAT   EQU      %                 DYADIC GREATER
DLESSEQ  EQU      %                 DYADIC LESS OR EQUAL
DGREATEQ EQU      %                 DYADIC GREATER OR EQUAL
*                                                                       U08-0039
*     SPECIAL CASE FOR LOGICAL ARGS                                     U08-0040
*                                                                       U08-0041
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,      U08-0042
         BLZ      DYOP3               DON'T DO SPECIAL CASING.          U08-0043
DYOP8    LI,T     LOGL                                                  U08-0044
         CB,T    *LFARG             TEST FOR BOTH-ARGS-LOGICAL          U08-0045
         BNE      DYOP3                                                 U08-0046
         CB,T    *RTARG                                                 U08-0047
         BNE      DYOP3                                                 U08-0048
         STW,T    RSTYPE            BOTH ARGS LOGL: SET UP TO DO        U08-0049
         LI,T     WORDLOGL            OP 32 BITS AT A TIME WITH         U08-0050
         STW,T    LFTYPE              LOGICAL OPERATORS.                U08-0051
         STW,T    RTTYPE                                                U08-0052
         ERROR,0,1-((DOPLESS&7)=6) 'NEXT INST WONT WORK'                U08-0053
         CI,OP    2                 SINGLES OUT > AND >= OPS            U08-0054
         BANZ     19Z4              FOR > AND >= SWAP ARGS AND          U08-0055
         EXCHANGE ARGS                TREAT AS < AND <=.                U08-0056
19Z4     BAL,L2   DSETUP            SET UP ARG/RESULT PARAMS            U08-0057
         BAL,L3   GXSEGDL           GEN LOAD OF LF ARG                  U08-0058
         CI,OP    DOPNEQ            FOR ALL EXCEPT 'NOT ='              U08-0059
         BE       19Z5                GEN 'NOT' OPERATION.              U08-0060
         GEN,0,1  EORINST                                               U08-0061
19Z5     LW,R     DOPTBL8,OP        GEN AND/OR/EOR OF RT ARG            U08-0062
         AW,R     RTADR                                                 U08-0063
         GEN,1,0  R                                                     U08-0064
         B        GXSTEXEC          GEN STORE/LOOP CODE; EXECUTE XSEG   U08-0065
*                                                                       U08-0066
*     GENERAL CASE                                                      U08-0067
*                                                                       U08-0068
DYOP3    BAL,LX   DTYPEIF           ALLOW NUMERIC ARGS; RSTYPE= I/F
         B        DYOP4             INTG
         BAL,L3   DSETUPL           FLOT: SET UP LOGL DB
         BAL,L3   GXSEGDL           GEN LOAD LEFT
         AW,R     LODBINST+FLOT     GEN LOAD OF RIGHT ARG
         GEN,1,1  R,BALCOMP         GEN FUZZ APPLIER
         LI,R     BF                SET NEW RT ADR = REG 'BF'
         B        GENCOMP
DYOP4    BAL,L3   DSETUPL           INTG: SET UP LOGL DB
         BAL,L3   GXSEGDL           GEN LOAD LEFT
GENCOMP  LW,T     RSTYPE
         AW,R     COMPINST,T        GEN COMPARE INST
         LW,R+1   DOPTBL4,OP        GET BRANCH INST
         GEN,2,4  R,STCCSEQ         GEN:  C..,AF   RTARG
         AWM,XL   -3,XL                   B..      %+3   (TRUE)
*                                         LI,AI    0     (FALSE)
         AWM,XL   -5,XL                   B        %+2
*                                         LI,AI    -1
*                                         BAL,LX   STLOGLRS
         LI,T     LOGL              RESTORE CORRECT RESULT TYPE
         XW,T     RSTYPE
         CI,T     CHAR
         BNE      19Z3
         LW,R     COPTRIG           IF IT'S A CHARACTER COMPARISON,
         BLZ      19Z3                BEING DONE AS A SCALAR OP,
         LI,R     3
         AW,R     RSSIZE              SET RSSIZE = NEXT HIGHER
         AND,R    =-4                 MULTIPLE OF FOUR CHARS.
         STW,R    RSSIZE
19Z3     BDR,XL   GXSTEXEC          DISCARD BAL...STLOGLRS, DO NORMAL
*                                     STORE GEN (BECAUSE OF COMPOSITE OPS).
*
*
DSETUPL  LI,T     LOGL              SET RSTYPE=LOGL
         XW,T     RSTYPE            SAVE OLD RSTYPE (INTG/FLOT)
         STW,T    TYPETEMP
         BAL,L2   DSETUP            NOW DO NORMAL DYADIC SETUP
         LW,T     TYPETEMP          RESTORE OLD RSTYPE
         STW,T    RSTYPE
         B       *L3                RETURN
*
TYPETEMP TEMP                       TEMP FOR SAVING RSTYPE
*
*
DOPTBL4  TABLE    DOPLESS           RELATIONAL BRANCH TABLE
         NBL      -2                <
         NBLE     -2                <=
         NBG      -2                >
         NBGE     -2                >=
         NBNE     -2                NOT =
         NBE      -2                =
*
*
DOPTBL7  TABLE    DOPNEQ            INST TABLE FOR 1='A' AND THE LIKE
         LI,AI    -1                NOT EQUAL
         LI,AI    0                 EQUAL
*                                                                       U08-0070
*                                                                       U08-0071
DOPTBL8  TABLE    DOPLESS           INST TBL FOR LOGL RELATIONALS       U08-0072
         AND,AI   0                 A < B         LW A; EOR =-1; AND B  U08-0073
         OR,AI    0                 A <= B        LW A; EOR =-1; OR  B  U08-0074
         AND,AI   0                 A > B         LW B; EOR =-1; AND A  U08-0075
         OR,AI    0                 A >= B        LW B; EOR =-1; OR  A  U08-0076
         EOR,AI   0                 A NOT= B      LW A;          EOR B  U08-0077
         EOR,AI   0                 A = B         LW A; EOR =-1; EOR B  U08-0078
*
*
STCCSEQ  EQU      %                 CODE FOR END OF RELAT OP
         LI,AI    0                 -4
         NB       -1      (%+2)     -3
         LI,AI    -1                -2
         BAL,LX   STLOGLRS          -1
*
*
BALCOMP  BAL,LX   FFCOMPAR          FUZZIFIER
*
*
COMPINST TABLE    CHAR              COMPARE INST - BY MODE:
         CB,AI    0                 CHAR
         CW,AI    0                 INTG
         CD,AF    0                 FLOT
         PAGE
*
*
DAND     EQU      %                 DYADIC AND
DOR      EQU      %                 DYADIC OR
DNAND    EQU      %                 DYADIC NAND
DNOR     EQU      %                 DYADIC NOR
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BLZ      11Z1                DON'T DO SPECIAL CASING.
         LI,T     LOGL              ARE BOTH TYPES LOGL ?
         CB,T    *LFARG
         BNE      11Z1              NO
         CB,T    *RTARG
         BE       11Z2              YES
11Z1     BAL,L1   DTYPEL            NO: SET UP TYPES
         B        11Z3              JOIN OTHER CASE
11Z2     STW,T    RSTYPE            BOTH ARGS LOGL: SET THEIR TYPES TO
         LI,T     WORDLOGL
         STW,T    RTTYPE              'WORD LOGICAL' FOR ADDRESSING
         STW,T    LFTYPE              THEM 32 BITS AT A TIME.
11Z3     BAL,L2   DSETUP
         BAL,L3   GXSEGDL           GEN LOADS/CONVERTS
         AW,R     DOPTBL6,OP        GEN AND/OR INST (DOES 1 OR 32 OPS)
         GEN,1,0  R
         CI,OP    DOPNAND           IS 'NEGATE' NEEDED ?
         BL       GXSTEXEC          NO, GEN STORE, ETC.
         GEN,0,1  EORINST           YES, GEN NEGATE-ALL-BITS INST
         B        GXSTEXEC          GEN STORE, ETC.
*
*
DOPTBL6  TABLE    DOPAND            AND/OR/NAND/NOR INST TABLE
         AND,AI   0                 AND
         OR,AI    0                 OR
         AND,AI   0                 NAND (FOLLOWED BY NEGATE)
         OR,AI    0                 NOR  (FOLLOWED BY NEGATE)
*
EORINST  EOR,AI   =-1               LOGICAL NEGATE INST (ALL 32 BITS)
         PAGE
*
*
DMINIMUM EQU      %                 DYADIC MINIMUM
DMAXIMUM EQU      %                 DYADIC MAXIMUM
         BAL,LX   DTYPEIF           CHECK TYPES
         NOP                        (DONT CARE IF IT'S I OR F)
         BAL,L2   DSETUP            SET UP SIZES/ADDRESSES
         BAL,L3   GXSEGDL           GEN LOADS/CONVERTS
         LW,T     RSTYPE
         AW,R     COMPINST,T        GEN:     COMPARE   RTADR
         LW,R+1   DOPTBL5,OP                 BLE/BGE   %+2
         LW,R+2   LOADINST,T                 LOAD      RTADR
         AW,R+2   RTADR
         GEN,3,0  R
         AWM,XL   -2,XL
         B        GXSTEXEC          GEN STORE, ETC.
*
*
DOPTBL5  TABLE    DOPMAX            MAX/MIN TABLE
         BGE      0       (%+2)     MAX
         BLE      0       (%+2)     MIN
         PAGE
*
*
*  T Y P E    C H E C K I N G    R O U T I N E S
*
*
*  MONADIC I/F TYPE
*
*              ALLOWS A NUMERIC (RIGHT) ARG.  SETS RTTYPE TO ARG
*              TYPE AND RSTYPE TO RESULT TYPE (INTG FOR LOGL/INTG
*              ARG, FLOT FOR FLOT ARG).  LINK IS LX; RETURNS TO
*              BAL+1 FOR I/L ARG, BAL+2 FOR F ARG.
*
MTYPEIF  EQU      %                 NUMERIC ARG, I/F RESULT
         STW,LX   TYPELINK         SAVE LINK IN CASE OF INTGOVFL
         LB,X    *RTARG             GET ARG TYPE
         STW,X    RTTYPE            SAVE IT
         B        %+1-LOGL,X        TEST IT:
         B        13Z1              L     RSTYPE = I
         B        ERDOMAIN          C     NOT ALLOWED
         B        13Z2              I     RSTYPE = I
         B        13Z3              F     RSTYPE = F
         B        13Z1              ISEQ  TREAT AS INTG
         B        ERDOMAIN          LIST  NOT ALLOWED
*
13Z1     LI,X     INTG              LOGL: SET TYPE = INTG
13Z2     STW,X    RSTYPE            INTG/LOGL: RSTYPE = INTG
         B        0,LX              INTG RETURN
*
13Z3     STW,X    RSTYPE            FLOT: RSTYPE = FLOT
         B        1,LX              FLOT RETURN
*
*
*  MONADIC F TYPE
*
*              ALLOWS NUMERIC ARG; SETS RTTYPE = ARG TYPE AND
*              RSTYPE = FLOT.  LINK IS L1.
*
MTYPEF   EQU      %                 NUMERIC ARG, F RESULT
         BAL,LX   MTYPEIF           ALLOW NUMERIC ARG; RSTYPE =
         MTW,FLOT-INTG  RSTYPE      INTG: CHANGE TO FLOT
         B       *L1                FLOT: RETURN
*
*
*  MONADIC I TYPE
*
*              ALLOWS NUMERIC ARG; SETS RTTYPE = ARG TYPE AND
*              RSTYPE = INTG.  LINK IS L1.
*
MTYPEI   EQU      %                 NUMERIC ARG, I RESULT
         BAL,LX   MTYPEIF           ALLOW NUMERIC ARG; RSTYPE =
         NOP
         LI,T     INTG                INTG
         STW,T    RSTYPE
         B       *L1                      RETURN
*
*
*  MONADIC L TYPE
*
*              ALLOWS NUMERIC ARG; SETS RTTYPE = ARG TYPE AND
*              RSTYPE = LOGL.  LINK IS L1.
*
MTYPEL   EQU      %                 NUMERIC ARG, L RESULT
         BAL,LX   MTYPEIF           ALLOW NUMERIC ARG; RSTYPE =
         NOP
         LI,T     LOGL                LOGL
         STW,T    RSTYPE
         B       *L1                      RETURN
         PAGE
*
*
*  DYADIC I/F TYPE
*
*              ALLOWS NUMERIC ARGS.  SETS LFTYPE/RTTYPE TO ARG TYPES
*              AND RSTYPE TO RESULT TYPE (INTG FOR LOGL/INTG ARGS,
*              FLOT IF EITHER ARG IS FLOT).  LINK IS LX; RETURNS TO
*              BAL+1 FOR INTG RESULT, BAL+2 FOR FLOT RESULT.
*
DTYPEIF  EQU      %                 NUMERIC ARGS, I/F RESULT
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BLZ     *CTYPELNK            DERAIL TO SPECIAL SUBROUTINE.
DTYPEIF1 LB,T    *LFARG             GET LEFT TYPE
DTYPEIF2 STW,T    LFTYPE            SAVE IT
         LB,X    *RTARG             GET RIGHT TYPE
         STW,X    RTTYPE            SAVE IT
         B        %+1-LOGL,T        TEST LEFT TYPE:
         B        5Z1-LOGL,X        L     TEST RIGHT TYPE
         B        ERDOMAIN          C     NOT ALLOWED
         B        5Z2-LOGL,X        I     TEST RIGHT TYPE
         B        5Z4-LOGL,X        F     TEST RIGHT TYPE
         B        5Z1-LOGL,X        ISEQ  TREAT AS INTG
         B        ERDOMAIN          LIST  NOT ALLOWED
*
5Z1      B        5Z6               L,L   RSTYPE=I
         B        ERDOMAIN          L,C   NOT ALLOWED
         B        5Z7               L,I   RSTYPE=RTTYPE (I)
         B        5Z3               L,F   RSTYPE=RTTYPE (F)
         B        5Z6               L,ISQ TREAT AS INTG
         B        ERDOMAIN          L,LST NOT ALLOWED
*
5Z2      B        5Z8               I,L   RSTYPE=LFTYPE (I)
         B        ERDOMAIN          I,C   NOT ALLOWED
         B        5Z7               I,I   RSTYPE=RTTYPE (I)
         B        5Z3               I,F   RSTYPE=RTTYPE (F)
         B        5Z8               I,ISQ TREAT AS INTG
         B        ERDOMAIN          I,LST NOT ALLOWED
*
5Z3      STW,X    RSTYPE            =F
         B        1,LX              RETURN
*
5Z4      B        5Z5               F,L   RSTYPE=LFTYPE (F)
         B        ERDOMAIN          F,C   NOT ALLOWED
         B        5Z5               F,I   RSTYPE=LFTYPE (F)
         B        5Z5               F,F   RSTYPE=LFTYPE (F)
         B        5Z5               F,ISQ TREAT AS INTG
         B        ERDOMAIN          F,LST NOT ALLOWED
*
5Z5      STW,T    RSTYPE            =F
         B        1,LX              RETURN
5Z6      LI,X     INTG              L,L   RSTYPE=I
5Z7      STW,X    RSTYPE            =I
         STW,LX   TYPELINK          SAVE LINK IN CASE OF INTGOVFL
         B        0,LX              RETURN
5Z8      STW,T    RSTYPE            =I
         STW,LX   TYPELINK          SAVE LINK IN CASE OF INTGOVFL
         B        0,LX              RETURN
*
TYPELINK TEMP                       REMEMBER LINK FOR INTGOVFL
*
*
*  DYADIC F TYPE
*
*              ALLOWS NUMERIC ARGS; SETS LFTYPE/RTTYPE TO ARG TYPES
*              AND RSTYPE TO FLOT.  LINK IS L1.
*
DTYPEF   EQU      %                 NUMERIC ARGS, F RESULT
         BAL,LX   DTYPEIF           ALLOW NUMERIC ARGS; RSTYPE=
         MTW,FLOT-INTG  RSTYPE      INTG: CHANGE TO FLOT
         B       *L1                FLOT: RETURN
*
*
*  DYADIC L TYPE
*
*              ALLOWS NUMERIC ARGS; SETS LFTYPE/RTTYPE TO ARG TYPES
*              AND RSTYPE TO LOGL.  LINK IS L1.
*
DTYPEL   EQU      %                 NUMERIC ARGS, L RESULT
         BAL,LX   DTYPEIF           ALLOW NUMERIC ARGS; RSTYPE=
         NOP
         LI,T     LOGL                LOGL
         STW,T    RSTYPE
         B       *L1                      RETURN
         PAGE
*
*
*  I S E Q    M A N I P U L A T I O N    R O U T I N E S
*
*
*  BUILD ISEQ RESULT
*
*              BUILDS AN ISEQ DATA BLOCK FOR THE RESULT, UNLESS
*              ANY OPERATION OVERFLOWS.  THE OP TO BE DONE IS
*              SPECIFIED IN 'OP' REG, AND THE INSTRUCTION AT BAL+1
*              WILL BE EXECUTED.  IF THERE'S NO OVERFLOW, THIS
*              ROUTINE BUILDS THE RESULT AND EXITS FROM THE OP
*              DRIVER (THROUGH 'RETURN'); OTHERWISE, IT RETURNS TO
*              ITS CALLER AT BAL+2, HAVING DEREFFED THE ISEQ DB
*              IT ESTABLISHED FOR THE RESULT.  LINK IS XL.
*
BILDISEQ LI,S     3                 ALLOCATE DB FOR RESULT ISEQ; IT'S
         BAL,LX7  ALOCHNW             SIZE IS HEADER + 3 WORDS.
         STW,A    RESULT            COPY RESULT DB PNTR
         LI,R     ISEQ**8+1         SET TYPE = ISEQ, RANK = 1.
         STH,R   *RESULT
         LW,T     LFARG             SET T= LEFT PTR
         LW,X     RTARG             SET X= RIGHT PTR
         EXU      0,XL              SET T=SCALAR ARG, X=ISEQ ARG
*     ONE ARG ISEQ, OTHER IS SCALAR (IF OP DYADIC)                      U08-0080
         LW,S     2,X               GET ISEQ LENGTH
         STW,S    2,A               SET RESULT ISEQ LENGTH
         LW,S     2,T               GET VALUE OF INTG/LOGL SCALAR       U08-0082
         LI,R     LOGL                                                  U08-0083
         CB,R    *T                                                     U08-0084
         BNE      4Z1               IF IT'S LOGICAL,                    U08-0085
         SCS,S    1                   CONVERT TO INTEGER.               U08-0086
         AND,S    =1                                                    U08-0087
4Z1      STW,S    DUMYISEQ+3        MAKE SCALAR VALUE LOOK LIKE ISEQ    U08-0088
         EXU      ISEQTBL1,OP         WITH BASE = VALUE,                U08-0089
         STW,S    DUMYISEQ+4          AND  STEP = 0 (+-) OR VALUE (*).  U08-0090
         LI,T     DUMYISEQ          T= NEW ISEQ PTR                     U08-0091
         EXU      0,XL              RESET T=LEFT, X=RIGHT
4Z2      LW,S     3,T               GET LEFT BASE/VAL                   U08-0093
ISEQ2    EXU      ISEQTBL2,OP       ADD/SUB/MUL RIGHT BASE/VAL
         BNOV     4Z3                                                   U08-0095
         B        ISEQOVFL
*     BOTH ARGS ISEQ (DYADIC OPS ONLY)                                  U08-0097
ISEQ1    LW,S     2,X               BOTH ARGS ISEQ,
         STW,S    2,A                 COPY SIZE TO RESULT ISEQ
         CW,S     2,T                 AND MAKE SURE SIZES AGREE.
         BE       4Z2                                                   U08-0099
         B        ERLENGTH
4Z3      STW,S    3,A               SET RESULT ISEQ BASE                U08-0101
         AI,X     1                 POINT TO STEP
         LW,S     4,T               GET LEFT STEP/VAL
         EXU      ISEQTBL2,OP       ADD/SUB/MUL RIGHT STEP/VAL
         BOV      ISEQOVFL
         STW,S    4,A               SET RESULT ISEQ STEP
         MW,S     2,A               MAKE SURE RESULT ISEQ
         BOV      ISEQOVFL            REPRESENTS COMPUTABLE INTEGERS.
         AW,S     3,A
         BNOV    *RETURN            RETURN
*
ISEQOVFL LI,A     0                 OVFL: DISCARD ISEQ PNTR,
         XW,A     RESULT
         BAL,LX7  DREF                DE-REF ISEQ DATA BLOCK,
         B        1,XL                AND RETURN.
*
*
ISEQTBL1 TABLE    DOPADD            EXU TABLE TO SET 'STEP' OF SCALAR
         LI,S     0                 DYADIC ADD
         LI,S     0                 DYADIC SUBTRACT
         NOP                        DYADIC MULTIPLY                     U08-0103
         B        ISEQ2             MONADIC NEGATE
*
*
ISEQTBL2 TABLE    DOPADD            EXU TABLE TO COMBINE BASES/STEPS
         AW,S     3,X               DYADIC ADD
         SW,S     3,X               DYADIC SUBTRACT
         MW,S     3,X               DYADIC MULTIPLY
         LCW,S    3,X               MONADIC NEGATE
*                                                                       U08-0105
*                                                                       U08-0106
DUMYISEQ EQU      LFTEMP-3          DUMMY ISEQ DATA BLOCK: ONLY WORDS   U08-0107
*                                     3 (BASE) AND 4 (STEP) NEEDED.     U08-0108
         PAGE
*
*
*  INTEGER OVERFLOW
*
*              WE ARRIVE HERE WHENEVER AN INTEGER OPERATION OVERFLOWS.
*              THE OPERATION IS RESTARTED IN THE FLOATING DOMAIN BY
*              CHANGING 'RSTYPE' FROM INTG TO FLOT AND GOING BACK TO
*              THE OP ROUTINE AT THE POINT WHERE IT CALLED THE TYPE
*              SETUP ROUTINE.
*
INTGOVFL EQU      %
         LI,A     0                 DISCARD RESULT PNTR
         STW,A    XSEGBRK           DON'T ALLOW BREAKS NOW
         XW,A     RESULT            DE-REF THE INTG RESULT DB
         BAL,LX7  DREF
         LW,OP    OPER              RESTORE THE OP CODE
         LI,T     INTG              PUT ARG TYPES BACK THE WAY THEY
         LB,T    *LFARG
         STW,T    LFTYPE              WERE AT 'DTYPEIF' TIME.
         LB,T    *RTARG
         STW,T    RTTYPE
         LI,T     FLOT              SET RESULT TYPE TO FLOT
         STW,T    RSTYPE
         LW,LX    TYPELINK          RESTORE OP ROUTINE'S LINK INTO
         B        1,LX                TYPE SUBR; TAKE 'FLOT' RETURN.
*
*
*  FLOATING DIVIDE BY ZERO TRAP
*
*              RESULTS IN DOMAIN ERROR IN ALL CASES EXCEPT
*              WHEN DOING A DYADIC DIVIDE OF 0 BY 0 (=1).
*
DIVZERO  EQU      %
         LI,A     X'FF'             MAKE SURE OP IS 'DYADIC DIVIDE'
         AND,A    OPER
         CI,A     DOPDIV
         BNE      0,LX              IF NOT, DOMAIN ERROR EXIT
         CD,AF    FLOT0             YES: MAKE SURE NUMERATOR
         BNEZ     0,LX                WAS ZERO.
         LD,AF    FLOT1             OK: SUBSTITUTE ANSWER OF 1.0
         B        1,LX              RETURN TO OK EXIT
         PAGE
*
*
*  O P E R A T O R    S E T U P    R O U T I N E S
*
*
* MONADIC OPERATOR SETUP ROUTINE
*
*              SETS UP FOR EXECUTION OF A MONADIC SCALAR OPERATOR.
*              IT IS CALLED WITH THE ARG AND RESULT TYPES SET UP
*              IN 'RTTYPE/RSTYPE'.  LINK IS L2.
*                   (1) ALLOCATES RESULT DATA BLOCK
*                   (2) ESTABLISHES RESULT DIMENSIONS
*                   (3) SETS UP THE SIZES IN 'RT/RSSIZE' AND
*                       THE ADDRESSES IN 'RT/RSADR'.
*
*
MSETUP   EQU      %
         LI,X     1
         LB,R    *RTARG,X           GET ARG RANK
         STW,R    RTRANK            SAVE IT FOR 'GETSIZE'
         LI,A     1
         BAL,LX   GETSIZE           GET ARG SIZE
         NOP                          (NO MATTER IF IT'S 1)
         STW,S    RSSIZE            = RESULT SIZE
         BAL,L1   ALOCRS            ALLOCATE RESULT DATA BLOCK
         LW,X     RSRANK
         BEZ      14Z2              IF RANK>0,
         MTW,1    RTARG
         MTW,1    RESULT
14Z1     LW,R    *RTARG,X               COPY ARG DIMENSIONS
         STW,R   *RESULT,X              TO RESULT DATA BLOCK.
         BDR,X    14Z1
         MTW,-1   RTARG
         MTW,-1   RESULT
14Z2     LI,X     -2                SET UP RTADR AND RSADR
         B        SETADRS1
*
*
*  DYADIC OPERATOR SETUP ROUTINE
*
*              SETS UP FOR EXECUTION OF A DYADIC SCALAR OPERATOR.
*              IT IS CALLED WITH THE ARG AND RESULT TYPES SET UP
*              IN 'LF/RT/RSTYPE'.  LINK IS L2.
*                   (1) PERFORMS CONFORMABILITY CHECKS
*                   (2) ALLOCATES RESULT DATA BLOCK
*                   (3) ESTABLISHES RESULT DIMENSIONS
*                   (4) SETS UP THE SIZES IN 'LF/RT/RSSIZE' AND
*                       THE ADDRESSES IN 'LF/RT/RSADR'.
*
*
DSETUP   EQU      %
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BLZ     *CSETLNK             DERAIL TO SPECIAL SUBROUTINE.
         LI,X     1
         LI,S     1                 1 FOR VECTOR/SCALAR TESTS
         LB,R    *LFARG,X           GET LEFT RANK
         STW,R    LFRANK            REMEMBER IT
         BEZ      1Z7               IS LEFT ARG A SCALAR ?
         LB,R    *RTARG,X           NO, GET RIGHT RANK
         STW,R    RTRANK            REMEMBER IT
         BEZ      1Z6               IS RIGHT ARG A SCALAR ?
         LI,A     1                 NO, GET ITS SIZE
         BAL,LX   GETSIZE
         B        1Z1               IS IT A ONE-ELMT ARRAY ?
         BAL,LX   GETLSIZE          YES, GET LEFT ARG SIZE
         B        1Z9               IS IT 1? IF NOT, USE LEFT RANK
         LW,R     RTRANK            NO, USE HIGHEST RANK
         CW,R     LFRANK            WE'VE ALREADY GOT THE LEFT RANK
         BLE      1Z9                 SET UP; IF IT'S THE HIGHEST,
         B        1Z2                 GREAT; ELSE, SWITCH TO RIGHT.
1Z1      BAL,LX   GETLSIZE          RT ARG ISN'T 1-ELMT; GET LF ARG SIZE
         B        1Z3               IS LF ARG 1-ELMT ?
         LW,R     RTRANK            YES, USE RIGHT RANK
1Z2      STW,R    RSRANK              (SET UP RT ARG RANK/SIZE)
         LW,S     RTSIZE
         LI,A     1
         B        1Z9
1Z3      LW,R     LFRANK            BOTH ARGS MULTI-ELMT, MAKE SURE
         CW,R     RTRANK              THEY ARE SHAPED ALIKE.
         BNE      ERRANK
         STW,S    RSSIZE            SET RESULT  SIZE
         BAL,L1   ALOCRS            GET RESULT DATA BLOCK; SET TYPE/RANK
         LW,X     RSRANK            IF RANK>0,
         BEZ      SETADRS
         MTW,1    LFARG             SET ARG POINTERS TO WORD BEFORE
         MTW,1    RTARG               FIRST DIMEN.
         MTW,1    RESULT            SET PNTR TO WORD BEFORE DIMENS
1Z4      LW,R    *LFARG,X           COPY ARG DIMENS TO RESULT DIMENS
         STW,R   *RESULT,X
         CW,R    *RTARG,X           MAKE SURE ARG DIMENS AGREE
         BE       1Z5
         MTW,-1   LFARG             RESTORE POINTERS TO THEIR
         MTW,-1   RTARG               ORIGINAL POSITION
         MTW,-1   RESULT
         B        ERLENGTH
1Z5      BDR,X    1Z4
         MTW,-1   LFARG             RESTORE POINTERS TO THEIR
         MTW,-1   RTARG               ORIGINAL POSITION
         MTW,-1   RESULT
         B        SETADRS           GO SET ADDRESSES
1Z6      STW,S    RTSIZE            RIGHT ARG SCALAR, SET SIZE=1
         BAL,LX   GETLSIZE          GET LEFT ARG SIZE
         B        1Z9               (MULTI-ELEM)  IN EITHER CASE, USE   08-00003
         B        1Z9               (ONE-ELEM)    LEFT RANK/SIZE/DIMENS.08-00004
1Z7      STW,S    LFSIZE            LEFT ARG SCALAR, SET SIZE=1
         LB,R    *RTARG,X           GET RIGHT RANK
         STW,R    RTRANK            REMEMBER IT
         BEZ      1Z8               IS RT ARG SCALAR, TOO?
         LI,A     1                 NO, GET RT ARG SIZE
         BAL,LX   GETSIZE
         B        1Z9               (MULTI-ELEM)  IN EITHER CASE, USE   08-00006
         B        1Z9               (ONE-ELEM)    RT ARG RANK/SIZE/DIMS.08-00007
1Z8      LI,R     0                 SCALAR RESULT:
         STW,R    RSRANK            RANK=0
         STW,S    RTSIZE
         STW,S    RSSIZE            SIZE=1
         BAL,L1   ALOCRS            GET RESULT DATA BLOCK; SET TYPE/RANK
         B        SETADRS           GO SET ADDRESSES (NO DIMENS TO MOVE)
1Z9      STW,S    RSSIZE            USE LF/RT RANK
         LW,T     A                 REMEMBER WHICH ARG TO USE
         BAL,L1   ALOCRS            GET RESULT DATA BLOCK; SET TYPE/RANK
         LW,T     LFARG,T
         LW,X     RSRANK            IF RANK>0,
         BEZ      SETADRS
         MTW,1    RESULT            SET PNTR TO WORD BEFORE DIMENS
         AI,T     1
1Z10     LW,R    *T,X                 COPY LF/RT DIMENS
         STW,R   *RESULT,X            TO RESULT DIMENS.
         BDR,X    1Z10
         MTW,-1   RESULT            RESTORE RESULT PNTR TO NORMALCY
*
*
*  SET ARG ADDRESS CELL(S)
*
*              'SETADR' SETS UP LFADR IF X=-3, RTADR IF X=-2, AND
*              RSADR IF X=-1;  LINK IS LX.  'SETADRS' SETS UP ALL
*              THREE; LINK IS L2.  'SETADRS1' SETS UP THE LAST
*              (-X) OF THEM; LINK IS L2.  FOR EACH ADR CELL BEING
*              SET UP, THE CORRESPONDING RANK, SIZE, AND TYPE CELLS
*              MUST BE ESTABLISHED.
*
SETADRS  EQU      %                 SET UP ADDRESSES
         LI,X     -3
SETADRS1 BAL,LX   SETADR            SET UP ONE ADR CELL
         BIR,X    SETADR1           SET UP ALL THREE OF 'EM
         B       *L2                RETURN
*
SETADR   LI,S     1                 SIZE OF 1 FOR VECTOR/SCALAR TESTS
SETADR1  EQU      %
3Z1      LW,A     RESULT+1,X        GET ARG WORD
         LW,T     RSTYPE+1,X        INITIALIZE ARG/RESULT ADDRESSES
         B        3Z12,T              ..DEPENDS ON DATA TYPE
3Z12     TABLE    WORDLOGL
         B        3Z11              WORD LOGICAL
         B        3Z10              LOGL
         B        3Z9               CHAR
         B        3Z6               INTG
         B        3Z4               FLOT
         LW,R     ISEQADR,X         ISEQ, SET ARG ADR = ADR OF
         STW,R    RSADR+1,X           ISEQ ELEMENT CALC ROUTINE.
         AI,A     4                 COMPUTE ISEQ STEP-VALUE LOC
         STW,A    LFSTEPAD+3,X      SAVE IT FOR ISEQ ELEMENT ROUTINE
         LW,R     -1,A              FETCH ISEQ BASE VALUE
         STW,R    LFVALU+3,X        STORE IT FOR ISEQ ELEMENT ROUTINE
         B        0,LX              RETURN
3Z4      EQU      %
         CW,S     RSSIZE+1,X        FLOT, IS IT SCALAR?
         BE       3Z2               YES, USE ARG+RANK+2
         INT,AI   0,A               GET DB SIZE
         AW,A     AI
         AI,A     N**17             USE ARG+(DB SIZE),N
         B        3Z3
3Z11     LI,T     WORDLOGL          WORD LOGICAL: CHANGE RSTYPE
         STW,T    RSTYPE              TO MATCH ARGS.
*                                   IF IT'S A SCALAR OR 1-ELMT
         CW,S     RSSIZE+1,X          THING, CHANGE ITS TYPE
         BE       3Z13                TO (BIT) LOGL & DO NORMALLY.
         LW,R     RSSIZE+1,X        OTHERWISE, KEEP WORDLOGL TYPE,
         AI,R     31                  CHANGE SIZES FROM BIT COUNT
         SLS,R    -5                  TO WORD COUNT; THEN CONTINUE AS
         STW,R    RSSIZE+1,X          FOR INTEGER TYPES.
3Z6      CW,S     RSSIZE+1,X        INTG: IS IT SCALAR?
         BE       3Z8               YES, USE ARG+RANK+2
         AW,A     RSSIZE+1,X        NO, USE ARG+SIZE+RANK+2,N
3Z7      AW,A     RSRANK+1,X        ADD ARG RANK TO ITS ADR
         AI,A     N**17+2           ADD 2 AND INDEX FIELD
         STW,A    RSADR+1,X         STORE ADDRESS
         B        0,LX              DONE
3Z9      CW,S     RSSIZE+1,X        CHAR: IS IT SCALAR?
         BE       3Z8               YES, USE ARG+RANK+2
         LW,A     RSSIZE+1,X        NO, ADVANCE SIZE TO NEXT
         AI,A     3                   MULTIPLE OF FOUR CHARS.
         AND,A    =-4
         STW,A    RSSIZE+1,X
         SLS,A    -2                USE ARG+CEILING(SIZE/4)+RANK+2,N
         AW,A     RESULT+1,X
         B        3Z7
3Z13     MTW,LOGL-WORDLOGL  RSTYPE+1,X
3Z10     LW,R     LOGLADR,X         LOGL: USE ADDRESS OF APPROPRIATE
         CW,S     RSSIZE+1,X          (SPECIAL CASE LOGL SCALAR)        08-00009
         BNE      3Z14                                                  08-00010
         LW,R     SLOGLADR,X                                            08-00011
         AI,A     1                                                     08-00012
3Z14     EQU      %                                                     08-00013
         STW,R    RSADR+1,X           LOGICAL LOAD/STORE ROUTINE
         LI,R     1                 INITIALIZE LOGL COUNT TO 1
         STW,R    RSLGLCNT+1,X
         AW,A     RSRANK+1,X        INITIALIZE LOGL ADDRESS TO
         AI,A     1                   ARG+RANK+1
         STW,A    RSLGLADR+1,X
         B        0,LX              DONE
3Z2      AW,A     RSRANK+1,X        FLOT SCALAR: USE
         AI,A     3                   ARG+RANK+(2 OR 3)
         AND,A    =-2                 (WHICHEVER IS EVEN)
         STW,A    RSADR+1,X
         B        0,LX
3Z8      AW,A     RSRANK+1,X        SCALAR
         AI,A     2                 USE ARG+RANK+2
3Z3      STW,A    RSADR+1,X         STORE ADR
         B        0,LX              RETURN
*
*
*  GET ARG SIZE
*
*              GETS SIZE OF LEFT (A=0) OR RIGHT (A=1) ARG TO 'S'
*              AND 'LFSIZE'/'RTSIZE'; COPIES ARG RANK TO 'RSRANK'.
*              LINK IS 'LX'.  IF SIZE=1, IT RETURNS TO BAL+2;
*              OTHERWISE, RETURNS TO BAL+1.
*              'GETLSIZE' IS ALTERNATE ENTRY WHICH SETS A=0 (LEFT).
*
GETLSIZE LI,A     0                 SET UP LF ARG INDEX
GETSIZE  LI,S     1                 1 TO COMPARE AGAINST DIMENS
         LW,R     LFRANK,A          GET ARG RANK
         STW,R    RSRANK            SET TENTATIVE RESULT RANK
         BEZ      2Z6               HANDLE ZERO-RANK CASE
         LW,X     LFARG,A           GET DIMEN PTR
         AI,X     1                 POINT TO WORD BEFORE 1ST DIMEN
2Z1      CW,S    *R,X               1:DIM
         BL       2Z3               1<DIM, START MULTIPLYING (SIZE>1)
         BE       2Z2               1=DIM, CONTINUE IN THIS LOOP
         LI,S     0                 1>DIM (DIM=0), STOP
         STW,S    LFSIZE,A          SET SIZE=0
         B        0,LX              RETURN TO 'NOT EQUAL 1' LOC
2Z2      BDR,R    2Z1
2Z6      STW,S    LFSIZE,A          SET ARG SIZE=1
         B        1,LX              SIZE=1 ; RETURN
2Z3      LW,S    *R,X               DIM>1, INITIALIZE SIZE=DIM
2Z4      BDR,R    2Z5               ARE THERE ANY MORE ?
         STW,S    LFSIZE,A          SET SIZE >1
         B        0,LX              NO, RETURN TO 'NOT EQUAL 1' LOC
2Z5      ODD,S
         MW,S    *R,X               SIZE = SIZE*DIM
         BNEZ     2Z4               CONTINUE IF NONZERO (SIZE STILL >1)
         STW,S    LFSIZE,A          SET SIZE=0
         B        0,LX              RETURN, SIZE NOT 1 (=0)
         PAGE
*
*
*  TEMPS FOR ARG SETUP
*
*
LFADR    TEMP                       LEFT ARG ADDRESS
RTADR    TEMP                       RIGHT ARG ADDRESS
RSADR    TEMP                       RESULT ADDRESS
LFLGLADR TEMP                       LOGICAL WORD ADR FOR LEFT ARG
RTLGLADR TEMP                       LOGICAL WORD ADR FOR RIGHT ARG
RSLGLADR TEMP                       LOGICAL WORD ADR FOR RESULT
LFLGLCNT TEMP                       LOGICAL BIT COUNT FOR LEFT ARG
RTLGLCNT TEMP                       LOGICAL BIT COUNT FOR RIGHT ARG
RSLGLCNT TEMP                       LOGICAL BIT COUNT FOR RESULT
LFSTEPAD TEMP                       LEFT ISEQ STEP ADDRESS
RTSTEPAD TEMP                       RIGHT ISEQ STEP ADDRESS
LFVALU   TEMP                       LEFT  ISEQ ELEMENT VALUE
RTVALU   TEMP                       RIGHT ISEQ ELEMENT VALUE
LFRANK   TEMP                       RANK OF LEFT  ARG
RTRANK   TEMP                       RANK OF RIGHT ARG
RSRANK   TEMP                       RANK OF RESULT
LFSIZE   TEMP                       SIZE OF LEFT  ARG
RTSIZE   TEMP                       SIZE OF RIGHT ARG
RSSIZE   TEMP                       SIZE OF RESULT
LFTYPE   TEMP                       TYPE OF LEFT  ARG
RTTYPE   TEMP                       TYPE OF RIGHT ARG
RSTYPE   TEMP                       TYPE OF RESULT
         PAGE
*
*
*  X S E G    G E N    R O U T I N E S
*
*
*  GEN XSEG INITIALIZATION CODE
*
*              GENS 'LCW,N  RSSIZE' AND DEFINES LOOP-TOP LOC.
*              LINK IS LX.  IF THE RESULT IS NULL, THIS ROUTINE EXITS
*              THROUGH 'RETURN'.
*
GXSEGINI LI,XL    XSEGBASE          INIT XSEG LOC COUNTER
         GEN,0,1  INITINST          GEN 'LCW,N  RSSIZE'
         STW,XL   LOOPLOC           DEFINE TOP-OF-LOOP LOC HERE
         LW,S     RSSIZE            IS RESULT NULL ?
         BNEZ     0,LX              NO, RETURN
         B       *RETURN            YES, EXIT FROM ENTIRE DRIVER
*
*
*  GEN MONADIC LOAD/CONVERT
*
*              SETS UP THE XSEG LOC COUNTER AND GENS:
*                   (1) LOOP INITIALIZATION
*                   (2) LOAD OF ARG
*                   (3) CONVERSION TO RESULT TYPE, IF NECESSARY
*              ALSO, IT ESTABLISHES THE LOOP-TOP LOC JUST AFTER (1).
*              LINK IS L1.
*
*
GXSEGML  EQU      %
         BAL,LX   GXSEGINI          GEN INIT, SET LOOPLOC
         LI,A     1                 GEN LOAD RIGHT ARG, CONVERT
         B        GENLOAD             TO RSTYPE; RETURN.
         PAGE
*
*
*  GEN DYADIC LOADS/CONVERTS
*
*              SETS UP THE XSEG LOC COUNTER AND GENS THE FOLLOWING:
*                   (1) LOOP INITIALIZATION
*                   (2) CONVERSIONS (IF NECESSARY) OF EACH ARG TO
*                       THE RESULT TYPE
*                   (3) LOAD OF THE LEFT ARG INTO THE 'A' REG
*              IN ADDITION, THE ROUTINE DOES THE FOLLOWING:
*                   (4) ESTABLISHES THE LOOP-TOP LOC (LEAVING STUFF
*                       OUTSIDE THE LOOP WHEREVER POSSIBLE); ITEMS
*                       (2) AND (4) MAY IMPLY GENNING LOADS/STORES
*                       TO TEMPS
*                   (5) LEAVES THE RIGHT ARG ADDRESS (WHICH MAY HAVE
*                       BEEN CHANGED TO A TEMP ADR) IN 'R'.
*              LINK IS L3.
*
*
GXSEGDL  EQU      %                 GEN XSEG LOADS/CONVERTS
         BAL,LX   GXSEGINI          GEN XSEG INIT CODE
         LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BLZ     *CLOADLNK            DERAIL TO SPECIAL SUBROUTINE.
         LI,S     1                 SIZE OF 1 FOR VECTOR/SCALAR TESTS
         CW,S     LFSIZE
         BNE      6Z1               IF LEFT ARG IS A SCALAR,
         LI,A     0                     LOAD IT TO ITS TEMP.
         BAL,L2   GENLOADT
         LI,S     1                 (GENLOADT MAY CLOBBER S)
6Z1      CW,S     RTSIZE
         BNE      6Z2               IF RIGHT ARG IS A SCALAR,
         LI,A     1                     LOAD IT TO ITS TEMP,
         BAL,L2   GENLOADT              THEN ESTABLISH 'TOP OF
         STW,XL   LOOPLOC               LOOP' HERE.
         B        6Z3
6Z2      STW,XL   LOOPLOC           IF RIGHT ARG IS VECTOR, 'TOP OF
         LW,T     RTTYPE              LOOP' IS HERE;
         CW,T     RSTYPE                IF IT'S OF THE WRONG TYPE,
         BNE      6Z4                   OR IF IT'S LOGL,
         CI,T     LOGL
         BNE      6Z3                   LOAD (AND CONVERT) IT INTO
GXSEGDL1 EQU      %
6Z4      LI,A     1                     ITS TEMP.
         BAL,L2   GENLOADT
6Z3      LI,A     0                 LOAD UP LEFT ARG
         BAL,L1   GENLOAD
         LW,R     RTADR             RETURN WITH R= RT ADR
         B       *L3                RETURN
*
*
*  GEN STORE AND LOOP CONTROL
*
*              GENS STORE INTO RESULT, FOLLOWED BY BIR TO LOOP-TOP
*              AND XSEG EXIT INST.  LINK IS LX.
*
GXSEGST  EQU      %                 GEN XSEG STORE, LOOP CONT
         LW,R     RSADR             GEN STORE INTO RESULT
         LW,T     RSTYPE
         AW,R     STORINST,T
         GEN,1,0  R
         LW,R     LOOPINST
         AW,R     LOOPLOC           GEN LOOP CONTROL INST
         GEN,1,1  R,EXITINST        GEN   LOOP CONTROL AND EXIT CODE
         B        0,LX              RETURN
         PAGE
*
*
*  GEN LOAD
*
*              GENS LOAD OF LEFT (A=0) OR RIGHT (A=1) ARG FOLLOWED,
*              IF NECESSARY, BY CONVERSION TO 'RSTYPE'. LINK IS L1.
*
GENLOAD  LW,R     LFADR,A           GET ADDRESS/INDEX FIELDS
         LW,T     LFTYPE,A
         CLM,R    TEMPADR
         BCS,9    18Z1              IF ADR IS LFTEMP/RTTEMP,
         AW,R     LTMPINST,T          GEN 'LOAD TEMP' INST (DIFFERS
         B        18Z2                FROM 'LOADINST' ONLY FOR LOGL.)
18Z1     AW,R     LOADINST,T        INSERT OP/REG FIELDS FOR LOAD
18Z2     GEN,1,0  R                 GEN LOAD INST
         CW,T     RSTYPE            IS TYPE CORRECT ?
         BE      *L1                YES, RETURN
         SLS,T    2                 NO, GEN TYPE CONVERSION:
         AW,T     RSTYPE                T = 4*(ARG TYPE)+(RESULT TYPE),
         GENX     CONVTABL,T        GEN CONVERSION CODE
         B       *L1                    RETURN
*
*
*  GEN LOAD TO TEMP
*
*              GENS LOAD AND CONVERT, AS ABOVE, FOLLOWED BY STORE
*              INTO TEMP; SUBSTITUTES TEMP ADR FOR ARG ADR. LINK IS L2.
*
GENLOADT BAL,L1   GENLOAD           GEN LOAD AND CONVERSION TO 'RSTYPE'
         LW,R     TEMPADR,A         SUBSTITUTE TEMP ADR
         STW,R    LFADR,A             FOR ARG ADR.
         LW,T     RSTYPE
         STW,T    LFTYPE,A          SUBSTITUTE RESULT TYPE
         AW,R     STMPINST,T        GEN STORE INTO TEMP
         GEN,1,0  R                 PUT IN XSEG
         B       *L2                RETURN
*
*
*  GEN CHANGE OF REGS OR OP CODE
*
*              IF THE LAST GENNED INST WAS A LOAD INST, ITS OP CODE
*              AND REG FIELDS WILL BE CHANGED TO THOSE GIVEN IN 'IX';
*              OTHERWISE, THE INST IN 'IX' WILL BE GENNED.  LINK IS LX.
*
CHANGOP  EQU      %
CHANGREG LW,IX1   =X'56000000'      IS LAST GEN'ED INST A LOAD ?
         CS,IX    -1,XL
         BE       7Z1
         GEN,1,0  IX                NO, GEN THE WHOLE INST
         B        0,LX
7Z1      LW,IX1   =X'7FF00000'      YES, CHANGE OP/REG FIELDS
         STS,IX   -1,XL
         B        0,LX
*
LREGBI   LW,BI    AI                CHANGE AI TO BI
LREGTX   LW,TX    AI                CHANGE AI TO TX
         PAGE
*
*
*  DATA/TEMPS FOR XSEG GEN ROUTINES
*
*
LOOPLOC  TEMP                       ADDRESS IN XSEG OF LOOP TOP
LFTEMP   DTEMP                      LEFT ARG TEMP
RTTEMP   DTEMP                      RIGHT ARG TEMP
*
*
LOADINST TABLE    WORDLOGL          LOAD INSTRUCTION - BY ARG TYPE:
         LW,AI    0                 WORD LOGICAL
         BAL,LX   0                 LOGL
         LB,AI    0                 CHAR
         LW,AI    0                 INTG
         LD,AF    0                 FLOT
         BAL,LX   0                 ISEQ
*
LODBINST TABLE    CHAR              LOAD 2ND ACCUM - BY ARG TYPE:
         LB,BI    0                 CHAR
         LW,BI    0                 INTG
         LD,BF    0                 FLOT
*
LTMPINST TABLE    WORDLOGL          LOAD FROM TEMP INST - BY ARG TYPE:
         LW,AI    0                 WORD LOGICAL
         LW,AI    0                 LOGL
         LB,AI    0                 CHAR
         LW,AI    0                 INTG
         LD,AF    0                 FLOT
         LW,AI    0                 ISEQ
*
STORINST TABLE    WORDLOGL          STORE INSTRUCTION - BY RESULT TYPE:
         STW,AI   0                 WORD LOGICAL
         BAL,LX   0                 LOGL
         STB,AI   0                 CHAR
         STW,AI   0                 INTG
         STD,AF   0                 FLOT
*
STMPINST TABLE    WORDLOGL          STORE TO TEMP INST - BY RS TYPE:
         STW,AI   0                 WORD LOGICAL
         STW,AI   0                 LOGL
         STB,AI   0                 CHAR
         STW,AI   0                 INTG
         STD,AF   0                 FLOT
*
LOGLADR  TABLE    -3                LOGL LOAD/STORE ROUTINES
         PZE      LDLOGLLF          LOAD LOGICAL LEFT ARG
         PZE      LDLOGLRT          LOAD LOGICAL RIGHT ARG
         PZE      STLOGLRS          STORE LOGICAL RESULT
*                                                                       08-00015
SLOGLADR TABLE    -3                SCALAR LOGL LOAD/STORE ROUTINES     08-00016
         PZE      LDSLGLLF          LOAD SCALAR LOGICAL LEFT            08-00017
         PZE      LDSLGLRT          LOAD SCALAR LOGICAL RIGHT           08-00018
         PZE      STSLGLRS          STORE SCALAR LOGICAL RESULT         08-00019
*
ISEQADR  TABLE    -3                ISEQ LOAD ROUTINES
         PZE      LDISEQLF          LOAD ISEQ ELEMENT LEFT
         PZE      LDISEQRT          LOAD ISEQ ELEMENT RIGHT
*
         BOUND    8
TEMPADR  TABLE    0                 ARG TEMP ADDRESS
         PZE      LFTEMP            LF
         PZE      RTTEMP            RT
*
CONVTABL TABLE    4*LOGL+WORDLOGL   CONVERSION CODE GROUPS - BY 2 TYPES:
         CODE,0                     L TO WORD LOGICAL
         CODE,0                     L TO L
         CODE,1   TYPEXTOC          L TO C   (FOR EQ/NEQ OPS)
         CODE,1   TYPELTOI          L TO I
         CODE,1   TYPELTOF          L TO F
         CODE,0                     C TO L   ILLEGAL
         CODE,0                     C TO C
         CODE,0                     C TO I   ILLEGAL
         CODE,0                     C TO F   ILLEGAL
         CODE,3   TYPEITOL          I TO L
         CODE,1   TYPEXTOC          I TO C   (FOR EQ/NEQ OPS)
         CODE,0                     I TO I
         CODE,5   TYPEITOF          I TO F
         CODE,5   TYPEFTOL          F TO L
         CODE,1   TYPEXTOC          F TO C   (FOR EQ/NEQ OPS)
         CODE,2   TYPEFTOI          F TO I
         CODE,0                     F TO F
         CODE,3   TYPEITOL          ISEQ TO L
         CODE,1   TYPEXTOC          ISEQ TO C
         CODE,0                     ISEQ TO I
         CODE,5   TYPEITOF          ISEQ TO F
*
TYPELTOI AND,AI   =1                INTG VAL = 0 OR 1
*
TYPELTOF LD,AF    FLOT01,AI         CONV LOGL 0/1 TO FLOT 0.0/1.0
*
TYPEITOF LW,AF   AI                GET INTG VALUE
         LI,AF1   0                 CLEAR 2ND WORD
         SAD,AF   -8                MAKE ROOM FOR EXPONENT
         EOR,AF   =X'48000000'      INCLUDE EXPONENT
         FAL,AF   FLOT0             NORMALIZE
*
TYPEFTOL EQU      %
*
TYPEFTOI BAL,LX   F2I               F TO I CONVERSION SUBROUTINE
         B        ERDOMAIN          ERROR IF NOT INTG VALUE
*
TYPEITOL CI,AI    -2                ERROR IF INTG NOT 0/1
         BANZ     ERDOMAIN
         LCW,AI   AI                SET TO 0 OR -1
*
TYPEXTOC LI,AI    -1                WON'T MATCH ANY CHAR
*
INITINST LCW,N    RSSIZE            XSEG LOOP INIT INST
LOOPINST BIR,N    0                 XSEG LOOP CONTROL INST
EXITINST B       *RETURN            XSEG EXIT INST
*
         BOUND    8
FLOTCONS DATA,8   FL'2',FL'1',FL'0'
FLOT0    EQU      FLOTCONS+4        FLOATING 0.0
FLOT1    EQU      FLOTCONS+2        FLOATING 1.0
FLOT2    EQU      FLOTCONS          FLOATING 2.0
FLOT01   EQU      FLOT0             FLOATING 0.0,1.0
FLOTPI   DATA,8   FL'3.141592653589793'
FLOTINF  DATA     X'7FFFFFFF',X'FFFFFFFF'
         PAGE
*
*
*  X S E G    E X E C U T I O N    R O U T I N E S
*
*
*  GEN INTEGER OVERFLOW TEST; GEN STORE; EXECUTE
*
GXOVSTEX GEN,0,2  OVTSTINS          GEN:     BNOV     %+2
         AWM,XL   -2,XL                      B        INTGOVFL
*
*
*  GEN STORE; EXECUTE
*
GXSTEXEC LW,X     COPTRIG           IF WE'RE DOING A COMPOSITE OP,
         BLZ     *CSTORLNK            DERAIL TO SPECIAL SUBROUTINE.
GXSTEXC1 BAL,LX   GXSEGST           GEN STORE, BY RESULT TYPE
*
*
*  EXECUTE XSEG
*
EXECUTE  LI,IX    OPBREAK           SET XSEG BREAK FLAG TO SAY,
         STW,IX   XSEGBRK             'XSEG BREAK IS OK NOW.'
         B        XSEGBASE          GO TO THE XSEG
*
*
*  LOAD/STORE LOGICAL DATA
*
*              LDLOGLLF/RT LOADS INTO ALL BIT POSITIONS OF AI
*              THE NEXT BIT OF LOGICAL DATA FROM LEFT/RIGHT
*              ARG.  STLOGLRS STORES AI (WHICH MUST BE 0 OR -1)
*              INTO THE NEXT LOGICAL RESULT BIT.  LINK IS LX.
*
LDLOGLLF LI,AF    0                 AF= LEFT ARG INDEX
         B        10Z1
*
LDLOGLRT LI,AF    1                 AF= RIGHT ARG INDEX
10Z1     LW,AI    LFLGLCNT,AF       GET COUNT (NR BITS REMAINING +1)
         BDR,AI   10Z2              DECR IT
         LI,AI    32                NO MORE BITS, RESET COUNT
         MTW,1    LFLGLADR,AF         AND GO TO NEXT WORD OF BITS.
10Z2     STW,AI   LFLGLCNT,AF       STORE NEW COUNT
         LW,AF    LFLGLADR,AF       FETCH CURRENT DATA ADR
         LW,AI    BITMASK,AI        SELECT   APPROPRIATE BIT
*                                     BITMASK+J = 2**(J-1)  FOR 1<=J<=32
         AND,AI   0,AF              GET THE BIT
         BEZ      0,LX              IF IT'S ZERO, RETURN WITH AI=0
         LI,AI    -1                NONZERO,
         B        0,LX                RETURN WITH AI=-1.
*
STLOGLRS LW,AF    RSLGLCNT          GET COUNT (NR POSITIONS LEFT +1)
         BDR,AF   10Z3              DECR IT
         MTW,1    RSLGLADR          NO MORE HOLES, RESET COUNT
         STW,AF   *RSLGLADR           AND MOVE TO NEXT FULL WORD.
         LI,AF    32                  ZERO OUT NEW WORD
10Z3     STW,AF   RSLGLCNT          STORE NEW COUNT
         AND,AI   BITMASK,AF        SELECT APPROPRIATE BIT
         ODD,AI                     SINCE AI IS ODD, 'STS,AI' DOES
         STS,AI  *RSLGLADR            'OR TO MEMORY'
         B        0,LX              RETURN
*                                                                       08-00021
*                                                                       08-00022
LDSLGLLF LW,AI   *LFLGLADR          GET LEFT ARG                        08-00023
         BGEZ     10Z4              TEST 1ST LOGL BIT                   08-00024
10Z5     LI,AI    -1                1: RETURN ALL 1'S                   08-00025
         B        0,LX                                                  08-00026
*                                                                       08-00027
LDSLGLRT LW,AI   *RTLGLADR          GET RIGHT ARG                       08-00028
         BLZ      10Z5              TEST 1ST LOGL BIT                   08-00029
10Z4     LI,AI    0                 0: RETURN ALL 0'S                   08-00030
         B        0,LX                                                  08-00031
*                                                                       08-00032
STSLGLRS STW,AI  *RSLGLADR          STORE LOGL SCALAR                   08-00033
         B        0,LX                                                  08-00034
*
*
*  LOAD ISEQ ELEMENT
*
*              LDISEQLF/RT LOADS INTO AI THE NEXT ELEMENT FROM
*              THE ISEQ ARG.  LINK IS LX.
*
LDISEQLF LW,AI    LFVALU            GET LAST VALUE
         AW,AI   *LFSTEPAD          ADD ISEQ STEP
         STW,AI   LFVALU            STORE AS NEXT VALUE
         B        0,LX                AND RETURN THAT VALUE
*
LDISEQRT LW,AI    RTVALU            GET LAST VALUE
         AW,AI   *RTSTEPAD          ADD ISEQ STEP
         STW,AI   RTVALU            STORE AS NEXT VALUE
         B        0,LX                AND RETURN THAT VALUE
*
*
OVTSTINS BNOV     0       (%+2)     -2
         B        INTGOVFL          -1
*
                  ERROR,X'F',TLOC>30  'TOO MANY TEMPS'                  U08-0110
NTEMPS   SET      TLOC                                                  U08-0111
20Z      END

