
; UCSD PASCAL I.5 INTERPRETER (FILE "mainop.mac")


         .TITLE  MAIN OPERATORS
         ;
         ; COPYRIGHT (C) 1978 REGENTS OF THE UNIVERSTIY OF CALIFORNIA.
         ; PERMISSION TO COPY OR DISTRIBUTE THIS SOFTWARE OR DOCUMEN-
         ; TATION IN HARD COPY OR SOFT COPY GRANTED ONLY BY WRITTEN LICENSE
         ; OBTAINED FROM THE INSTITUTE OF INFORMATION SYSTEMS.  ALL RIGHTS
         ; RESERVED.  NO PART OF THIS PUBLICATION MAY BE REPRODUCED, STORED
         ; IN A RETRIEVAL SYSTEM ( E.G., IN MEMORY, DISK, OR CORE) OR BE
         ; TRANSMITTED BY ANY MEANS, ELECTRONIC, MECHANICAL, PHOTOCOPY,
         ; RECORDING, OR OTHERWISE, WITHOUT PRIOR WRITTEN PERMISSION FROM THE
         ; PUBLISHER.
         ;
         ;
         .CSECT  MAINOP

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;                       MAIN OPERATORS                              ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ; FIRST ARE THE SHORT FORM LDL,LDO, AND IND OPS.
 ; THESE ARE THE MOST COMMON OPS (EXCEPT LDCI) AND RUN
 ; VERY FAST.  EACH DISP VALUE FOR THESE IS A NEW OPCODE

 ; SHORT LOCAL LOADS...16 OF THEM
 SLDLS:  .IRP    N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20>
         MOV     <N+N>+MSDLTA(MP),-(SP)
         BR      BACK
         .ENDR

 ; SHORT LOAD GLOBALS...16 OF THEM
 SLDOS:  .IRP    N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20>
         MOV     <N+N>+MSDLTA(BASE),-(SP)
         BR      BACK
         .ENDR

 ; SHORT IND OPS...8 OF THEM
 SINDS:  MOV     @(SP)+,-(SP)
         BR      BACK
         .BLKW   2       ; FUNNY BUSINESS FOR EXTRA FAST IND 0
         .IRP    N,<1,2,3,4,5,6,7>
         ADD     #<N+N>,@SP
         MOV     @(SP)+,-(SP)
         BR      BACK
         .ENDR
         .PAGE
 ;;;;;;;;;;;;;;;;;;;;;;;
 ; MAIN INTERPRETER LOOP
 ; GO HERE FOR OPCODE
 ; FETCH SEQUENCE
 ;;;;;;;;;;;;;;;;;;;;;;;;

 SLDCI:  MOV     R0,-(SP)        ; PUSH THE LIT VALUE AND FALL INTO NEXT OP
 BACK:   GETNEXT                 ; GET NEXT INSTRUCTION BYTE
         BPL     SLDCI           ; IF POSITIVE THEN A SHORT LDCI
         ASL     R0              ; DOUBLE FOR WORD INDEXING
         MOV     XFRTBL(R0),PC   ; TRANSFER CONTROL TO PROPER OP

 ABI:    ; INTEGER ABSOLUTE VALUE
         TST     @SP
         BPL     1$
         NEG     @SP
         BPL     1$
         CLR     @SP
 1$:     MORE

 ABR:    ; REAL ABSOLUTE VALUE
         BIC     #100000,@SP
         MORE

 ADI:    ; ADD INTEGER
         ADD     (SP)+,@SP
         MORE

 ADR:    ; ADD REAL
         .IF     DF,FPI
         FADD    SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $ADR,XITFP
         .ENDC

 AND:    ; LOGICAL AND
         COM     @SP
         BIC     (SP)+,@SP
         MORE

 BPT:    ; CONDITIONAL HALT (BREAKPOINT)
         GETBIG                  ; LINE IN LIST FILE
         MOV     R0,HLTLIN
         CMP     BUGSTA,#3
         BGE     BPTTRP
         ; NOT IN STEPPING MODE, SO SEE IF MATCHES A BREAKPOINT
         MOV     #BRKPTS,R1
         CMP     (R1)+,R0
         BEQ     BPTTRP
         CMP     (R1)+,R0
         BEQ     BPTTRP
         CMP     (R1)+,R0
         BEQ     BPTTRP
         CMP     (R1),R0
         BEQ     BPTTRP
         MORE
 BPTTRP: TRAP    BRKPNT

 DIF:    ; SET DIFFERENCE
         JSR     PC,SETADJ
         BEQ     2$
 1$:     BIC     (SP)+,(R0)+
         SOB     R1,1$
									
 2$:     MORE

 DVI:    ; INTEGER DIVIDE
         MOV     (SP)+,R1
         MOV     (SP)+,R0
         JSR     PC,DIV
         MOV     R0,-(SP)
         MORE

 DVR:    ; REAL DIVIDE
         .IF     DF,FPI
         FDIV    SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $DVR,XITFP
         .ENDC

 CHK:    ; CHECK INDEX OR RANGE
         CMP     (SP)+,2(SP)     ; CHECK MAXIMUM VALUE
         BLT     CHKERR
         CMP     (SP)+,@SP       ; CHECK MINIMUM VALUE
         BGT     CHKERR
         MORE
 CHKERR: TRAP    INVNDX

 FLO:    ; FLOAT NEXT TO TOP-OF-STACK
         MOV     (SP)+,FLO1      ; SAVE REAL ON TOS
         MOV     (SP)+,FLO0
         JSR     R4,ENTFP
         .WORD   $IR,FIXTOS,XITFP
 FIXTOS: MOV     (PC)+,-(SP)
 FLO0:   .WORD
         MOV     (PC)+,-(SP)
 FLO1:   .WORD
         JMP     @(R4)+

 FLT:    ; FLOAT TOP-OF-STACK
         JSR     R4,ENTFP
         .WORD   $IR,XITFP

 INN:    ; SET INCLUSION
         MOV     (SP)+,BK        ; GET SET SIZE FROM STACK
         MOV     SP,R0           ; NOW POINT R0 AT THE SCALAR VAL
         ADD     BK,R0           ; BY SKIPPING IT ABOVE
         ADD     BK,R0           ; THE SET
         MOV     @R0,R1          ; R1 HAS THE VALUE TO TEST FOR NOW
         BMI     NOTINN          ; NO NEGATIVE SET INDEXES
         .IF     DF,EIS
         ASH     #-4,R1
         .IFF
         ASR     R1
         ASR     R1
         ASR     R1
         ASR     R1
         .ENDC

         CMP     R1,BK           ; CHECK IF ENOUGH WORD ARE IN SET
         BGE     NOTINN          ; TO ACCOMODATE THE VALUE IN R1
         ASL     R1              ; IF THERE ARE, POINT R1 AT THE WORD
         ADD     SP,R1           ; WHICH HAS THE BIT IN IT
         MOV     @R1,BK          ; PLACE THE WORD INTO BK FOR LATER
         MOV     @R0,R1          ; GET THE SCALAR AGAIN
         BIC     #177760,R1      ; CHUCK ALL BUT LOW 4 BITS
         ASL     R1              ; MAKE A WORD INDEX INTO BITTER
         BIT     BITTER(R1),BK   ; TEST IF THE BIT IN QUESTION IS ON
         BEQ     NOTINN
         MOV     R0,SP           ; FOUND IT...CUT BACK STACK
         MOV     #1,@SP          ; PUT A TRUE ON TOP
 XITINN: MOV     #BACK,BK        ; RESTORE REGISTER
         MORE
 NOTINN: MOV     R0,SP           ; CUT BACK HERE TOO
         CLR     @SP             ; EXCEPT PUSH A FALSE
         BR      XITINN


 INT:    ; SET INTERSECTION
         JSR     PC,SETADJ
         MOV     R1,TOPSIZ       ; SAVE TOP SET SIZE
         BEQ     2$
 1$:     COM     @SP
         BIC     (SP)+,(R0)+
         SOB     R1,1$
 2$:     MOV     @SP,R1          ; GET FINAL SET SIZE
         SUB     TOPSIZ,R1       ; SUBTRACT THE TOP SIZE...R1 = DIFF
         BEQ     4$              ; IF NO LEFTOVER WORDS THEN EXIT
 3$:     CLR     (R0)+           ; ELSE CLEAR EXTRA WORDS IN FINAL SET
         SOB     R1,3$
 4$:     MORE
 TOPSIZ: .WORD           ; SIZE OF TOP SET (TEMP)

 IOR:    ; LOGICAL OR
         BIS     (SP)+,@SP
         MORE

 MOD:    ; INTEGER REMAINDER DIVIDE
         MOV     (SP)+,R1
         MOV     (SP)+,R0
         JSR     PC,DIV
         MOV     R1,-(SP)
         MORE

 MPI:    ; INTEGER MULTIPLY
         MOV     (SP)+,R0
         MOV     (SP)+,R1
         JSR     PC,MLI
         MOV     R0,-(SP)
         MORE

 MPR:    ; REAL MULTIPLY
         .IF     DF,FPI
         FMUL    SP
         MORE

         .IFF
         JSR     R4,ENTFP
         .WORD   $MLR,XITFP
         .ENDC

 NGI:    ; INTEGER NEGATION
         NEG     @SP
         MORE

 NGR:    ; REAL NEGATION
         TST     @SP
         BEQ     1$
         ADD     #100000,@SP
 1$:     MORE

 NOT:    ; LOGICAL NOT
         COM     @SP
         MORE

 SRS:    ; BUILD SUBRANGE SET
         MOV     (SP)+,R0        ; GRAB HIGHER VALUE J OF I..J
         MOV     (SP)+,R1        ; AND LOWER VALUE I
         BMI     NULSET          ; IF I IS NEG THEN NULL SET TIME
         CMP     R1,R0           ; IF I > J THEN
         BGT     NULSET          ; ALSO A NULL SET
         MOV     #1,SETWDS       ; FINAL SET SIZE...START WITH 1 WORD
         MOV     #177777,-(SP)   ; OF ALL ONES
         MOV     R0,BK           ; CLEAR HIGH BITS 15 DOWNTO J
         BIC     #177760,BK      ; USE LOW BITS IN BK FOR CLRMSK INX
         ASL     BK              ; DOUBLE FOR WORDS INDEX
         BIC     CLRMSK+2(BK),@SP ; HIGH ORDER BITS GONE NOW
         BIS     #17,R0          ; FIND WORDS TO PUT BETWEEN I..J
         SUB     R1,R0           ; HAVE DIFFERENCE NOW * 16
         .IF     DF,EIS
         ASH     #-4,R0          ; DIV 16...NUMBER WORDS FROM I..J
         .IFF
         ASR     R0
         ASR     R0
         ASR     R0
         ASR     R0
         .ENDC
         BEQ     2$              ; IF ZERO, THEN 1 WORD IS ENOUDH
         ADD     R0,SETWDS       ; ELSE BUMP SET SIZE COUNTER
 1$:     MOV     #177777,-(SP)   ; AND PUSH ALL BIT SET WORDS
         SOB     R0,1$           ; FOR NUMBER WORDS DIFFERENCE
 2$:     MOV     R1,BK           ; NOW ZAP LOW BITS ON TOS WORD
         BIC     #177760,BK      ; THAT ARE LESS THAN I VALUE
         ASL     BK              ; WORD INDEX
         MOV     CLRMSK(BK),BK   ; GRAB HIGH ORDER CLEARING BIT MASK
         COM     BK              ; CHANGE TO LOW ORDER MASK
         BIC     BK,@SP          ; NOW THE ON BITS IN SET ARE OK
         .IF     DF,EIS
         ASH     #-4,R1          ; DIV 16...# OF ZERO TO PUSH NOW
         .IFF
         ASR     R1
         ASR     R1
         ASR     R1
         ASR     R1
         .ENDC
         BEQ     4$              ; IF NO MORE ZEROES THEN SKIP
         ADD     R1,SETWDS       ; ELSE ADD ON ZERO COUNT TO SET SIZE
 3$:     CLR     -(SP)           ; AND LOOP ADDING ON ZEROES
         SOB     R1,3$
 4$:     MOV     SETWDS,-(SP)    ; PUSH SET SIZE...NOW GOOD, CLEAN SET ON STACK
         MOV     #BACK,BK
         MORE
 SETWDS: .WORD   ; SIZE OF SET BUILD ABOVE STUCK HERE

 SBI:    ; INTEGER SUBTRACT
         SUB     (SP)+,@SP
         MORE

 SBR:    ; REAL SUBTRACT
         .IF     DF,FPI
         FSUB    SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $SBR,XITFP
         .ENDC

         ; SGS IS BELOW THE SQUARE OP

 SQI:    ;  SQUARE INTEGER
         MOV     @SP,-(SP)
         BR      MPI

 SQR:    ; SQUARE REAL
         MOV     2(SP),-(SP)
         MOV     2(SP),-(SP)
         BR      MPR

 NULSET: CLR     -(SP)           ; ZERO WORD SET SIZE
         MORE

 SGS:    ; MAKE SINGLETON SET
         MOV     (SP)+,R0        ; GET THE SCALAR VALUE WANTED
         BMI     NULSET          ; IF NEGATIVE THEN GO BUILD A NULL SET
         CLR     -(SP)           ; PUT A WORD TO SET BIT INN
         MOV     R0,R1           ; NOW SET PROPER BIT IN TOS
         BIC     #177760,R1      ; ZAP ALL BUT LOW 4 BITS
         ASL     R1              ; MAKE A WORD INDEX IN BITTER
         BIS     BITTER(R1),@SP  ; NOW WE HAVE PROPER BIT SET
         BIC     #170017,R0      ; ZAP ALL BUT WORD BITS
         BEQ     2$              ; IF NO ZEROES NEEDED THEN DONE
         .IF     DF,EIS
         ASH     #-4,R0
         .IFF
         ASR     R0
         ASR     R0
         ASR     R0
         ASR     R0
         .ENDC
         MOV     R0,R1           ; SAVE WORD COUNT FOR LATER PUSH
 1$:     CLR     -(SP)           ; CLEAR A STACK WORD
         SOB     R1,1$
 2$:     INC     R0              ; SET R0 TO TOTAL SET SIZE
         MOV     R0,-(SP)        ; AND PUSH IT FINALLY
         MORE

 STO:    ; STORE INDIRECT
         MOV     (SP)+,@(SP)+
         MORE

 IXS:    ; STRING INDEX...DYNAMIC RANGE CHECK
         MOV     @SP,R0          ; GRAB INDEX VALOUE
         BEQ     IXSERR          ; ZERO INDEX IS AN ERROR
         CMP     R0,#255.        ; CHECK IF WAY TOO BIG
         BHI     IXSERR          ; BOMB IF SO
         CMPB    R0,@2(SP)       ; CHECK INDEX AGAINST STRING LENGTH
         BHI     IXSERR          ; AND BOMB FOR THAT TOO
         ADD     (SP)+,@SP       ; OK...ADD THE INDEX TO ADDR ON TOS
         MORE
 IXSERR: TRAP    INVNDX

 UNI:    ; SET UNION
         JSR     PC,SETADJ
         BEQ     2$
 1$:     BIS     (SP)+,(R0)+
         SOB     R1,1$
 2$:     MORE

 S2P:    ; STRING TO PACKED ARRAY CONVERT
         INC     2(SP)
         MORE

 LDCN:   ; LOAD CONSTANT NIL
         .IIF    EQ,NIL,         CLR     -(SP)
         .IIF    NE,NIL,         MOV     #NIL,-(SP)
         MORE

 ADJ:    ; SET ADJUST
         GETBYTE                 ; GRAB REQUESTED SET SIZE
         MOV     (SP)+,R1        ; GET SET SIZE FROM TOS
         CMP     R1,R0           ; COMPARE SET SIZE TO REQ SIZE
         BLT     EXPAND          ; IF SET TOO SMALL THEN EXPAND IT
         BGT     CRUNCH          ; IF TOO BIG THEN CRUNCH THE SET
         MORE                    ; ELSE ALL'S OK...NEXT INSTRUCTION
 CRUNCH: MOV     R0,BK           ; SAVE REQUESTED LENGTH
         ASL     R0              ; NOW POINT R0 AT TOP OF VALID PART OF SET
         ADD     SP,R0
         ASL     R1              ; POINT R1 ABOVE ENTIRE SET...IS DEST
         ADD     SP,R1           ; FOR FUTURE MOVES TO CRUNCH OUT JUNK
 1$:     MOV     -(R0),-(R1)     ; COPY THE WORDS OF GOOD SEOT PART
         SOB     BK,1$
         MOV     R1,SP           ; R1 IS NEW TOS...CUT BACK STUFF
         BR      XITADJ
 EXPAND: MOV     SP,BASE         ; REMEMBER TOP OF SMALL SET
         SUB     R1,R0           ; R0 HAS SET SIZE DIFFERENCE NOW
         MOV     R0,BK           ; SAVE DIFF FOR LATER ZEROING
         ASL     R0              ; DOUBLE FOR WORD COUNT
         SUB     R0,SP           ; ADD JUNK ONTO STACK POINTER FOR ZERO FILL
         MOV     SP,R0           ; NOW DEST FOR SET COPYING
         TST     R1              ; CHECK IF OLD SET SIZE = 0!!
         BEQ     2$              ; IF SO THEN DONT DO LOOP...SYSBOMB!
 1$:     MOV     (BASE)+,(R0)+   ; COPY THE SET NOW
         SOB     R1,1$
 2$:     CLR     (R0)+           ; NOW ZERO IN THE REST OF SET
         SOB     BK,2$
         MOV     STKBAS,BASE     ; RESTORE SCRATCH REG
 XITADJ: MOV     #BACK,BK        ; RESTORE THIS TOO
         MORE

         ; FJP IS UP AHEAD WITH UJP

 INC:    ; INCREMENT TOS BY PARAM
         GETBIG
         ADD     R0,@SP
         MORE

 IND:    ; INDIRECT LOAD
         GETBIG
         ASL     R0
         ADD     R0,@SP
         MOV     @(SP)+,-(SP)
         MORE

 IXA:    ; INDEX ARRAY
         GETBIG  R1              ; GET # WORDS PER ELEMENT
         MOV     (SP)+,R0        ; GRAB USER'S INDEX VALUE
         BEQ     2$              ; IF ZERO, THEN DONE ALREADY!
         CMP     R1,#1           ; CHECK IF 1 WORD ELS
         BEQ     1$              ; IF SO THEN NO MULTIPLY
         JSR     PC,MLI
 1$:     ASL     R0              ; NOW DOUBLE INDEX VALUE FOR WORDS
         ADD     R0,@SP          ; NEW ADDRESS OFO ARRAY ELEMENT NOW
 2$:     MORE

 LAO:    ; LOAD GLOBAL ADDRESS
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     BASE,R0
         MOV     R0,-(SP)
         MORE

 LCA:    ; LOAD CONSTANT (STRING) ADDRESS
         MOV     IPC,-(SP)
         GETBYTE                 ; GRAB STRING LENGTH
         ADD     R0,IPC          ; AND SKIP IPC PAST STRING
         MORE

 LDO:    ; LOAD GLOBAL
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     BASE,R0
         MOV     @R0,-(SP)
         MORE

 MOV:    ; MOVE WORDS
         GETBIG  BK              ; GRAB # WORDS TO MOVE (ALWAYS > 0)
         MOV     (SP)+,R0        ; SOURCE ADDRESS
         MOV     (SP)+,R1        ; DESTINATION ADDRESS
 1$:     MOV     (R0)+,(R1)+     ; COPY EACH WORD
         SOB     BK,1$
         MOV     #BACK,BK
         MORE

 MVB:    ; MOVE BYTES
         GETBIG  BK              ; GRAB # BYTES TO MOVE (ALWAYS > 0)
         MOV     (SP)+,R0        ; SOURCE ADDRESS
         MOV     (SP)+,R1        ; DESTINATION ADDRESS
 1$:     MOVB    (R0)+,(R1)+     ; COPY EACH BYTE
         SOB     BK,1$
         MOV     #BACK,BK
         MORE

 SAS:    ; STRING ASSIGNMENT
         MOV     (SP)+,R0        ; GET SOURCE STRING ADDRESS
         CMP     R0,#255.        ; CHECK IF ITS REALLY A CHAR
         BHI     1$              ; IF NOT THEN SKIP TRICKYNESS
         MOVB    R0,LITCHR+1     ; LIT CHAR...MAKE IT A STRING
         MOV     #LITCHR,R0      ; NOW R0 HAS GOOD ADDRESS
 1$:     CMPB    @R0,(IPC)+      ; CHEOCK IF MAXLENG IS EXCEEDED BY SRC LENG
         BHI     SASERR          ; BOMB OUT IF SO
         MOV     (SP)+,R1        ; GRAB DESTINATION ADDRESS
         CLR     BK              ; SET UP LOOP COUNTER WITH SOURCE LENGTH
         BISB    @R0,BK          ; NOW BK HAS LENGTH COUNT OF SOURCE
         INC     BK              ; INCLUDE LENGTH BYTE IN LOOP COUNT
 2$:     MOVB    (R0)+,(R1)+     ; COPY EACH BYTE
         SOB     BK,2$           ; LOOP FOR CHARS+LENGTH BYTE
         MOV     #BACK,BK        ; RESTORE
         MORE
 LITCHR: .WORD   1               ; DUMMY STRING OF LENGTH 1
 SASERR: TRAP    S2LONG

 SRO:    ; STORE GLOBAL
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     BASE,R0
         MOV     (SP)+,@R0
         MORE

 XJP:    ; INDEX JUMP
         WORDBOUND
         MOV     (SP)+,R0        ; GRAB INDEX VALUE FROM TOS
         MOV     (IPC)+,R1       ; GET MIN CASE INDEX FROM CODE
         CMP     R0,R1           ; SEE IF INDEX IS TOO SMALL
         BLT     MINERR          ; SKIP OUT IF NOT IN RANGE
         CMP     R0,(IPC)+       ; CHECK IF LEQ MAX VALUE
         BGT     MAXERR          ; SKIP OUT HERE TOO
         TST     (IPC)+          ; SKIP OVER ELSE JUMP WORD
         SUB     R1,R0           ; ADJUST INDEX TO 0..N
         ASL     R0              ; DOUBLE INDEX FOR WORD STUFF
         ADD     R0,IPC          ; POINT IPC AT PROPER JUMP TABLE INDEX
         SUB     @IPC,IPC        ; NOW IPC POINTS AT STATEMENT SELECTED
         MORE
 MINERR: TST     (IPC)+          ; SKIP IPC TO ELSE JUMP LOCATION
 MAXERR: MORE                    ; IPC POINTS AT ELSE JUMP...ONWARD

 COMPAR: ; COMPARE COMPLEX THINGS
         ; RELOPS EQU, GRT, GEQ, LEQ, LES, & NEQ
         GETNEXT R1              ; GRAB COMPARISON TYPE
         MOV     CMPTBL(R1),PC   ; NOW TRANSFER TO PROPER CODE

 REALCMP:; COMPARE REAL
         MOV     SBROPS(R0),1$
         .IF     DF,FPI
         FSUB    SP
 1$:     NOP
         BR      2$
         TST     (SP)+
         MOV     #1,@SP
         MORE
 2$:     TST     (SP)+
         CLR     @SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $CMR,1$,XITFP
 1$:     NOP
         BR      2$
         MOV     #1,-(SP)
         JMP     @(R4)+
 2$:     CLR     -(SP)
         JMP     @(R4)+
         .ENDC

 STRGCMP:; COMPARE STRINGS
         MOV     UBROPS(R0),NOTEQL       ; SELF-MODIFY UNSIGNED BRANCH
         MOV     2(SP),R0        ; GET LEFT OPERAND ADDRESS
         CMP     R0,#255.        ; BUT IT MAY BE A CHAR!
         BHI     1$              ; IF SO, THEN PUT IN LITCHR TRICK
         MOVB    R0,LITCHR+1     ; TO GET A STRING OF 1 LENGTH
         MOV     #LITCHR,R0      ; AND POINT REGISTER AT IT
         MOV     R0,2(SP)        ; BE SURE TO FIX STACK TOO
 1$:     MOV     @SP,R1          ; GRAB RIGHT SIDE ADDRESS
         CMP     R1,#255.        ; SAME LITCHR BUSINESS
         BHI     2$              ; AS ABOVE
         MOVB    R1,LITCHR+1
         MOV     #LITCHR,R1
         MOV     R1,@SP
 2$:     CLR     BK              ; NOW GET LENG = MIN(LENGTH(R0),LENGTH(R1))
         CMPB    (R0)+,(R1)+     ; CHECK MIN LENG, POINT REGS AT TEXT
         BHIS    3$              ; IF LENG(R0) < LENG(R1) THEN
         BISB    -1(R0),BK       ; BK := LENGTH(R0)
         BR      4$
 3$:     BISB    -1(R1),BK       ; ELSE BK := LENG(R1)
 4$:     BEQ     EQUALS          ; BR IF RUN OFF END OF STRINGS (BK = 0)
         CMPB    (R0)+,(R1)+     ; COMPARE STRING CONTENTS
         BNE     NOTEQL          ; ANY NEQ CHAR STOPS CMP
         DEC     BK
         BR      4$              ; LOOP UNTIL OFF END
 EQUALS: ; WELL, STRINGS = FOR MIN LENGTH...CMP LENGTHS
         CMPB    @2(SP),@0(SP)   ; LONGER STRING IS GREATER!
 NOTEQL: NOP     ; CORRECT BR OP GOES HERE
         BR      2$              ; JUMP TO FALSE CASE
         MOV     #1,2(SP)        ; PLACE A TRUE IN STACK
 1$:     TST     (SP)+           ; FINALLY RETURN
         MOV     #BACK,BK
         MORE
 2$:     CLR     2(SP)           ; FALSE
         BR      1$

 WORDCMP:; COMPARE WORDS
         GETBIG  BK
         ASL     BK
         BR      CMP.IT
 BYTECMP:; COMPARE BYTE STRING
         GETBIG  BK
 CMP.IT: MOV     UBROPS(R0),2$   ; PUT IN PROPER CMP OPERATOR
         MOV     (SP)+,R1        ; RIGHT HAND EXPRESSION ADDR
         MOV     (SP)+,R0        ; LEFT EXPRESSION
 1$:     CMPB    (R0)+,(R1)+     ; COMPARE BYTES
         BNE     2$              ; ANY NEQ STOPS LOOP
         SOB     BK,1$
 2$:     NOP
         BR      4$
         MOV     #1,-(SP)
 3$:     MOV     #BACK,BK
         MORE
 4$:     CLR     -(SP)
         BR      3$


 BOOLCMP:; COMPARE BOOLEAN OPERANDS
         BIC     #177776,@SP
         BIC     #177776,2(SP)
         MOV     XFRTBL+40.(R0),PC       ; DO INTEGER COMPARE

 POWRCMP:; COMPARE SETS
         JSR     PC,SETADJ       ; ENSURE SETS MAKE SENSE
         MOV     -(R0),BK        ; GET LOWER SET SIZE
         ADD     (R0)+,BK        ; DOUBLE FOR BYTE SIZE
         ADD     R0,BK           ; NOW BK POINTS AT FINAL TOP OF STACK
         MOV     BK,NEWSP
         MOVB    -2(IPC),BK      ; GRAB ORIGINAL INSTRUCTION BYTE
         ASL     BK              ; DOUBLE IT!! WORD INDEX IN XFRSET
         MOV     XFRSET(BK),-(SP) ; STASH TRANSFER ADDRESS...
         MOV     -2(R0),BK       ; ACTUAL OPS EXPECT BK=LOWER SET SIZE
         MOV     (SP)+,PC        ; TRANSFER NOW TO PROPER COMPARE OP

 EQUS:   ; COMPARE SETS EQUAL
         TST     R1              ; NUMBER OF WORDS IN TOP SERT
         BEQ     CHKZER
 1$:     CMP     (SP)+,(R0)+
         BNE     SFALSE
         DEC     BK
         SOB     R1,1$
 CHKZER: TST     BK
         BEQ     STRUE
 1$:     TST     (R0)+
         BNE     SFALSE
         SOB     BK,1$
         BR      STRUE

 LEQS:   ; LESS THAN OR EQUAL SET COMPARE
         TST     R1
         BEQ     CHKZER
 1$:     BIC     (SP)+,(R0)+
         BNE     SFALSE
         DEC     BK
         SOB     R1,1$
         BR      CHKZER

 GEQS:   ; GREATER OR EQUAL SET COMPARE
         TST     R1
         BEQ     STRUE
 1$:     BIC     (R0)+,(SP)+
         BNE     SFALSE
         SOB     R1,1$
         BR      STRUE

 NEQS:   ; NOT EQUAL SET COMPARE
         TST     R1
         BEQ     2$
 1$:     CMP     (SP)+,(R0)+
         BNE     STRUE
         DEC     BK
         SOB     R1,1$
 2$:     TST     BK
         BEQ     SFALSE
 3$:     TST     (R0)+
         BNE     STRUE
         SOB     BK,3$
 SFALSE: MOV     NEWSP,SP
         CLR     -(SP)
 XITPWR: MOV     #BACK,BK
         MORE
 STRUE:  MOV     NEWSP,SP
         MOV     #1,-(SP)
         BR      XITPWR
 NEWSP:  .WORD

 LDA:    ; LOAD INTERMEDIATE ADDRESS
         GETNEXT                 ; THE DELTA LEX LEVEL
         MOV     MP,R1           ; POINT R1 AT STAT LINKS
 1$:     MOV     @R1,R1          ; LINK DOWN NOW UNTIL
         SOB     R0,1$           ; DELTA LL = 0 (NEVER START AT 0)
         GETBIG                  ; GET DISPLACMENT
         ASL     R0              ; DOUBLE FOR WORD INDEXING
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     R1,R0           ; NOW R0 HAS ADDRESS
         MOV     R0,-(SP)        ; PUSH IT
         MORE

 LDC:    ; LOAD MULTIWORD CONSTANT
         GETNEXT                 ; NUMBER OF WORDS TO LOAD (ALWAYS > 0)
         WORDBOUND
 1$:     MOV     (IPC)+,-(SP)
         SOB     R0,1$
         MORE

 LOD:    ; LOAD INTERMEDIATE VALUE
         GETNEXT                 ; THE DELTA LEX LEVEL
         MOV     MP,R1           ; POINT R1 AT STAT LINKS
 1$:     MOV     @R1,R1          ; LINK DOWN NOW UNTIL
         SOB     R0,1$           ; DELTA LL = 0 (NEVER START AT 0)
         GETBIG                  ; GET DISPLACMENT
         ASL     R0              ; DOUBLE FOR WORD INDEXING
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     R1,R0           ; NOW R0 HAS ADDRESS
         MOV     @R0,-(SP)       ; COPY VALUE FROM STACK
         MORE

 STR:    ; STORE INTERMEDIATE VALUE
         GETNEXT                 ; THE DELTA LEX LEVEL
         MOV     MP,R1           ; POINT R1 AT STAT LINKS
 1$:     MOV     @R1,R1          ; LINK DOWN NOW UNTIL
         SOB     R0,1$           ; DELTA LL = 0 (NEVER START AT 0)
         GETBIG                  ; GET DISPLACMENT
         ASL     R0              ; DOUBLE FOR WORD INDEXING
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     R1,R0           ; NOW R0 HAS ADDRESS
         MOV     (SP)+,@R0       ; SAVE VALUE INTO STACK
         MORE

 NOJUMP: INC     IPC             ; GO HERE IF A TRUE WAS ON STACK
         MORE

 EFJ:    ; INTEGER = THEN FJP
         SUB     (SP)+,(SP)+
         BEQ     NOJUMP
         BR      UJP

 NFJ:    ; INTEGER <> THEN FJP
         SUB     (SP)+,(SP)+
         BNE     NOJUMP
         BR      UJP

 FJP:    ; BRANCH IF FALSE ON TOS
         ROR     (SP)+
         BCS     NOJUMP
         ; NOW FALL INTO UJP

 UJP:    ; BRANCH UNCONDITIONAL
         GETNEXT                 ; GET BRANCH PARAM
         BMI     1$              ; IF < 0 THEN A LONG JUMP
         ADD     R0,IPC          ; ELSE JUST A BYTE OFFSET FORWARD
         MORE
 1$:     MOV     JTAB,IPC        ; POINT IPC AT JTAB ENTRY SO OFFSET
         ADD     R0,IPC          ; IS GOOD...R0 IS < 0   REALLY A SUBTRACT
         SUB     @IPC,IPC        ; POINT IPC AT NEW OBJECT CODE
         MORE

 LDP:    ; LOAD PACKED FIELD
         MOV     @4(SP),R0       ; GET WORD WHICH HAS FIELD IN IT INTO R0
         MOV     (SP)+,R1        ; GET FIELD RIGHT-MOST BIT NUMBER
         .IF     DF,EIS
         NEG     R1
         ASH     R1,R0
         .IFF
         BEQ     NOASR           ; IF ZERO THEN NO SHIFTS NEEDED
 1$:     ASR     R0              ; SHIFT R0 UNTIL FIELD IN LOW BITS
         SOB     R1,1$
 NOASR:
         .ENDC
         MOV     (SP)+,R1        ; GRAB FIELD WIDTH FROM STACK
         ASL     R1              ; DOUBLE IT FOR WORD INDEXING
         BIC     CLRMSK(R1),R0   ; CLEAR SHIT BITS IN WORD
         MOV     R0,@SP          ; NOW PUT FIELD ON STACK
         MORE

 STP:    ; STORE PACKED FIELD
         MOV     4(SP),R1        ; GRAB FIELD WIDTH
         ASL     R1              ; DOUBLE FOR WORD INDEX
         MOV     CLRMSK(R1),R1   ; NOW WE HAVE A CLEARING MASK IN R1
         MOV     (SP)+,R0        ; GRAB INSERT VALUE FROM STACK
         BIC     R1,R0           ; ZAP JUNK BITS IN INSERT VALUE
         COM     R1              ; NOW R1 WILL ZAP THE FIELD ITSELF
         MOV     (SP)+,BK        ; GET FIELD RIGHT-MOST BIT
         .IF     DF,EIS
         ASH     BK,R0
         ASH     BK,R1
         .IFF
         BEQ     NOASL           ; IF IN RIGHT-MOST BIT THEN NO SHIFT
 1$:     ASL     R0              ; SHIFT INSERT VALUE BY ONE
         ASL     R1              ; AND SHIFT CLEAR MASK
         SOB     BK,1$           ; AND DO SO UNTIL LINED UP WITH FIELD
 NOASL:
         .ENDC
         TST     (SP)+           ; FORGET THE OLD FIELD WIDTH
         MOV     (SP)+,BK        ; BK NOW HAS ADDRESS OF PACKED FIELD WORD
         BIC     R1,@BK          ; SET FIELD IN WORD TO ZEROES
         BIS     R0,@BK          ; NOW OR IN THE INSERT VALUE
         MOV     #BACK,BK        ; RESTORE SCRATCH REG
         MORE

 LDM:    ; LOAD MULTIPLE WORDS
         MOV     (SP)+,R1        ; GET WORD LIST ADDRESS
         GETBYTE                 ; AND GET WORD COUNT
         BEQ     NOLOAD          ; MAY HAPPEN SOMEDAY
         ADD     R0,R1           ; SKIP LIST ADDRESS TO UPPER END
         ADD     R0,R1           ; R1 NOW POINTS ABOVE DATA BLOCK
 1$:     MOV     -(R1),-(SP)
         SOB     R0,1$
 NOLOAD: MORE

 STM:    ; STORE MULTIPLE WORDS
         GETBYTE                 ; GET NUMBER OF WORDS
         BEQ     NOSTOR
         MOV     SP,R1           ; POINT R1 AT DATA BLOCK ON STACK
         ADD     R0,R1           ; SKIP R1 PAST THE DATA TO GET THE
         ADD     R0,R1           ; STORE ADDRESS BELOW IT
         MOV     @R1,R1          ; GET STORE ADDRESS NOW
 1$:     MOV     (SP)+,(R1)+
         SOB     R0,1$
 NOSTOR: TST     (SP)+           ; CHUCK ADDRESS WORD
         MORE

 LDB:    ; LOAD BYTE
         MOV     @SP,R0
         CLR     @SP
         BISB    @R0,@SP
         MORE

 STB:    ; STORE BYTE
         MOVB    (SP)+,@(SP)+
         MORE

 IXP:    ; INDEX PACKED ARRAY
         GETNEXT R1              ; GET # ELEMENTS PER WORD
         MOV     (SP)+,R0        ; GET USER'S INDEX VALUE
         JSR     PC,DIV          ; NOW DIVIDE OUT WORD INX AND BIT INX
         ADD     R0,@SP          ; ADD WORD INDEX TO BASE ADDR ON TOS
         ADD     R0,@SP          ; TO BUILD WORD ADDRESS FOR LDP
         GETNEXT                 ; GET ELEMENT WIDTH
         MOV     R0,-(SP)        ; NOW PUSH EL WIDTH FOR LDP STUFF
         CLR     -(SP)           ; NOW THE RIGHT-MOST BIT
 1$:     ASR     R1              ; NOW A SHORT MULTIPLY FOR SMALL VALUES
         BCC     2$              ; SKIP IF THE MULTIPLICAND BIT IS OFF
         ADD     R0,@SP
 2$:     ASL     R0              ; DOUBLE ADDEND
         TST     R1              ; ANY MULTIPLICATION AT ALL?
         BNE     1$              ; IF SO THEN KEEP LOOPING
         MORE

 EQUI:   ; INTEGER EQUAL COMPARE
         SUB     (SP)+,@SP
         BEQ     PSHTRU
 PSHFLS: CLR     @SP
         MORE
 PSHTRU: MOV     #1,@SP
         MORE

 GEQI:   ; INTEGER GREATER OR EQUAL COMPARE
         SUB     (SP)+,@SP
         BGE     PSHTRU
         BR      PSHFLS

 GRTI:   ; INTEGER GREATER THAN COMPARE
         SUB     (SP)+,@SP
         BGT     PSHTRU
         BR      PSHFLS

 LLA:    ; LOAD LOCAL ADDRESS
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     MP,R0
         MOV     R0,-(SP)
         MORE

 LDCI:   ; LOAD LONG INTEGER CONSTANT
         MOVB    (IPC)+,-(SP)
         MOVB    (IPC)+,1(SP)
         MORE

 LEQI:   ; INTEGER LESS THAN OR EQUAL COMPARE
         SUB     (SP)+,@SP
         BLE     PSHTRU
         BR      PSHFLS

 LESI:   ; INTEGER LESS THAN COMPARE
         SUB     (SP)+,@SP
         BLT     PSHTRU
         BR      PSHFLS

 LDL:    ; LOAD LOCAL
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     MP,R0
         MOV     @R0,-(SP)
         MORE

 NEQI:   ; INTEGER NOT EQUAL COMPARE
         SUB     (SP)+,@SP
         BNE     PSHTRU
         BR      PSHFLS

 STL:    ; STORE LOCAL
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     MP,R0
         MOV     (SP)+,@R0
         MORE

 S1P:    ; STRING TO PACKED ON TOS
         INC     @SP
         MORE

 IXB:    ; INDEX BYTE ARRAY
         ADD     (SP)+,@SP
         MORE

 BYT:    ; CONVERT WORD TO BYTE ADDR
         MORE

 ; EQUAL FJP AND NOT EQUAL FJP ARE AT FJP

 XIT:    ; EXIT SYSTEM
         HALT
         TRAP    SYSERR

 NOP:    ; NO OPERATION
         MORE

 ENTFP:  ; THIS SUBROUTINE STARTS THE THREADED CODE
         ; SEQUENCE A-LA FPMP $POLSH.  THE DIFFERENCE IS
         ; WE SAVE IPC REGISTER (R4)
         MOV     (SP)+,FPIPC     ; IPC MUST BE R4!!!
         JMP     @(R4)+          ; THREAD IT

 FPIPC:  .WORD   ; SAVE R4 (IPC) REG HERE

 XITFP:  ; HERE IS WHERE WE EXIT FROM FPMP BUSINESS
         MOV     LASTMP,MP
         MOV     #BACK,BK
         MOV     STKBAS,BASE
         MOV     FPIPC,IPC
         MORE

 SETADJ: ; THIS IS A SUBROUTINE CALLED BY SET OPERATIONS
         ; TO MASSAGE SET SIZES AND REGISTERS...SEE THOSE OPS
         MOV     (SP)+,RETADR    ; SAVE RETURN ADDRESS
 TRYAGN: MOV     (SP)+,R1        ; GRAB SET SIZE
         MOV     SP,R0           ; NOW POINT R0 AT NEXT SET
         ADD     R1,R0
         ADD     R1,R0
         CMP     (R0)+,R1        ; COMPARE FIRST SET SIZE WITH SECOND (TOP) SIZE
         BGE     SETSOK          ; QUIT IF SIZES ARE OK
         MOV     R1,-(SP)        ; ELSE EXPAND LOWER SET BY SHOVING IN 0-S
         MOV     -(R0),BK        ; GET SMALLER SET SIZE
         MOV     R1,@R0          ; CHANGE IT TO FINAL SIZE AFTER EXPAND
         MOV     R1,R0           ; CALCULATE NUMBER OF EXTRA ZEROES NEEDED
         SUB     BK,R0           ; R0 = TOPSIZE-LOWERSIZE
         MOV     R0,ZEROES       ; STASH IT FOR LATER USE
         ADD     BK,R1           ; NOW SET R1 TO TOTAL NUMBER OF WORDS TO COPY
         ADD     #2,R1           ; BE SURE TO INCLUDE SIZE WORDS
         MOV     SP,BK           ; POINT BK AT OLD TOS
         ASL     R0              ; DOUBLE SIZE DIF TO BYTES
         SUB     R0,SP           ; AND BUMP STACK TO MAKE ROOM
         MOV     SP,R0           ; NOW R0 IS DEST POINTER FOR COPY
 1$:     MOV     (BK)+,(R0)+     ; COPY EACH WORD IN STACK
         SOB     R1,1$           ; LOOP FOR TOTAL SET SIZES
         MOV     ZEROES,R1       ; NOW COPY IN ZEROES BELOW SETS
 2$:     CLR     (R0)+
         SOB     R1,2$
         MOV     #BACK,BK        ; RESTORE REG
         BR      TRYAGN          ; RESET REGISTERS AND EXIT
 ZEROES: .WORD   ; TEMP FOR ABOVE EXPAND
 SETSOK: TST     R1              ; LEAVE CC WITH R1 VALUE
         JMP     @(PC)+          ; BACK TO CALLER...LEAVE CC ALONE
 RETADR: .WORD

         .PAGE
         .CSECT  TABLES
         .GLOBL  XFRTBL
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;                       OPERATOR TRANSFER TABLES                    ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 XFRTBL  = . + 400       ; USE NEGATIVE INDEXES TO GET TO OPS
         .WORD   ABI
         .WORD   ABR
         .WORD   ADI
         .WORD   ADR
         .WORD   AND
         .WORD   DIF
         .WORD   DVI
         .WORD   DVR
         .WORD   CHK
         .WORD   FLO
         .WORD   FLT
         .WORD   INN
         .WORD   INT
         .WORD   IOR
         .WORD   MOD
         .WORD   MPI
         .WORD   MPR
         .WORD   NGI
         .WORD   NGR
         .WORD   NOT
         .WORD   SRS
         .WORD   SBI
         .WORD   SBR
         .WORD   SGS
         .WORD   SQI
         .WORD   SQR
         .WORD   STO
         .WORD   IXS
         .WORD   UNI
         .WORD   S2P
         .BLKW   1
         .WORD   LDCN
         .WORD   ADJ
         .WORD   FJP
         .WORD   INC
         .WORD   IND
         .WORD   IXA
         .WORD   LAO
         .WORD   LCA
         .WORD   LDO
         .WORD   MOV
         .WORD   MVB
         .WORD   SAS
         .WORD   SRO
         .WORD   XJP
         .BLKW   2
         .WORD   COMPAR
         .WORD   COMPAR
         .WORD   COMPAR
         .WORD   LDA
         .WORD   LDC
         .WORD   COMPAR
         .WORD   COMPAR
         .WORD   LOD
         .WORD   COMPAR
         .WORD   STR
         .WORD   UJP
         .WORD   LDP
         .WORD   STP
         .WORD   LDM
         .WORD   STM
         .WORD   LDB
         .WORD   STB
         .WORD   IXP
         .BLKW   2       ; CBP RNP
         .WORD   EQUI
         .WORD   GEQI
         .WORD   GRTI
         .WORD   LLA
         .WORD   LDCI
         .WORD   LEQI
         .WORD   LESI
         .WORD   LDL
         .WORD   NEQI
         .WORD   STL
         .BLKW   3.
         .WORD   S1P
         .WORD   IXB
         .WORD   BYT
         .WORD   EFJ
         .WORD   NFJ
         .WORD   BPT
         .WORD   XIT
         .WORD   NOP
         .LIST   ME
         .IRP    N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20>
         .WORD   SLDLS+<6*<N-1>>
         .ENDR
         .IRP    N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20>
         .WORD   SLDOS+<6*<N-1>>
         .ENDR
         .IRP    N,<0,1,2,3,4,5,6,7>
         .WORD   SINDS+<10*N>
         .ENDR
         .NLIST  ME

         .BLKW   3*<MAXUNT+1>    ; UNIT TABLE IN IOTRAP

 CMPTBL: .WORD   0
         .WORD   REALCMP
         .WORD   STRGCMP
         .WORD   BOOLCMP
         .WORD   POWRCMP
         .WORD   BYTECMP
         .WORD   WORDCMP

 XFRSET  = . + 242
         .WORD   EQUS
         .WORD   GEQS
         .WORD   0,0,0
         .WORD   LEQS
         .WORD   0,0
         .WORD   NEQS

 SBROPS  = . + 242
         BEQ     .+4
         BGE     .+4
         BGT     .+4
         TRAP    SYSERR
         TRAP    SYSERR
         BLE     .+4
         BLT     .+4
         TRAP    SYSERR
         BNE     .+4

 UBROPS  = . + 242
         BEQ     .+4
         BHIS    .+4
         BHI     .+4
         TRAP    SYSERR
         TRAP    SYSERR
         BLOS    .+4
         BLO     .+4
         TRAP    SYSERR
         BNE     .+4

         .RADIX  2.

 BITTER: 0000000000000001
         0000000000000010
         0000000000000100
         0000000000001000
         0000000000010000
         0000000000100000
         0000000001000000
         0000000010000000
         0000000100000000
         0000001000000000
         0000010000000000
         0000100000000000
         0001000000000000
         0010000000000000
         0100000000000000
         1000000000000000

 CLRMSK: 1111111111111111
         1111111111111110
         1111111111111100
         1111111111111000
         1111111111110000
         1111111111100000
         1111111111000000
         1111111110000000
         1111111100000000
         1111111000000000
         1111110000000000
         1111100000000000
         1111000000000000
         1110000000000000
         1100000000000000
         1000000000000000
         0000000000000000

         .END

; +------------------------------------------------------------------+
; |                                                                  |
; |                     F     I     N     I     S                    |
; |                                                                  |
; +------------------------------------------------------------------+