;-*-Mode:Midas; base: 8; readtable: ZL-*-
;;;
;;; (c) Copyright 1984 - Lisp Machine, Inc.
;;;

(DEFCONST UC-LOGICAL '(
; SHIFTING WITH CONS ...
;   THE CONS HARDWARE TAKES THE OPPOSITE APPROACH FROM MOST MACHINES IN THAT
; LDB AND DPB ARE PRIMITIVE AND SHIFTS HAVE TO BE BUILT UP OUT OF THEM INSTEAD
; OF THE OTHER WAY AROUND.  FOR THE PURPOSES OF CONS, THIS IS USUALLY A GREAT
; WIN, BUT IT DOES MAKE FOR A CERTAIN AMOUNT OF PAIN WHEN REALLY TRYING TO DO A SHIFT.
;   FURTHER PAIN IS CAUSED WHEN THE AMOUNT OF THE SHIFT MUST COME FROM THE
; "DATA" SIDE OF THE MACHINE (AS WITH ROT AND LSH) INSTEAD OF BEING A CONSTANT AMOUNT
; KNOWN AT MICRO-ASSEMBLY TIME.  WHEN THIS IS THE CASE,
;  (1) THE ARGUMENT MUST BE "MOVED" FROM THE DATA SIDE TO THE CONTROL SIDE BY THE USE
;	OF OA- TYPE DESTINATIONS.  AS A COLLARY OF THIS, IT IS NECESSARY TO MASK THINGS
;	CAREFULLY TO AVOID RANDOMNESS, AND THERE IS NOT MUCH FLEXIBILITY AS TO 
;	WHAT SIGNS THINGS HAVE ETC.  VARIOUS "QUIRKS" OF THE HARDWARE, NORMALLY
;	COMPENSATED FOR BY THE MICRO-ASSEMBLER, MUST BE DELT WITH BY THE USER:
;	(A) THE BYTE LENGTH FIELD IS REALLY THE	<BYTE-LENGTH-1> FIELD.
;	    ALSO, BECAUSE THE FIELD IS 5 BITS LONG, ZERO BIT BYTES DONT WIN
;	    AT ALL (THEY "BECOME" 32. BYTES).
;	(B) ONE MUST REMEMBER THE M-ROTATE IS ALWAYS A LEFT ROTATE.  THIS IS 
;	    "NATURAL" FOR DPB, BUT ON LDB THE MICROASSEMBLER NORMALLY HAS TO 
;	    BUGGER THINGS TO COMPENSATE AND MAKE IT APPEAR A RIGHT SHIFT IS
;	    BEING DONE.  NATURALLY, USING OA- MODIFIERS, THERE IS NO OPPORTUNITY
;	    FOR THIS TO HAPPEN WITHOUT BEING EXPLICITLY CODED IN MICRO-INSTRUCTIONS.
;	    THE BUGGER REQUIRED IS TO "REPLACE" THE M-ROTATE FIELD WITH
;	      (LOGAND 37 (- 40 <"NATURAL" M-ROTATE>)).
;  (2) THE POSSIBITY OF CONSTRUCTING AN "ILLEGAL" BYTE POINTER ON A DPB MUST BE 
;	CAREFULLY CONSIDERED.  BRIEFLY, THE SUM <BYTE-LENGTH-1> + <M-ROTATE> MUST BE
;	LESS THAN OR EQUAL TO 37 OCTAL.  IF IT IS GREATER, THE HARDWARE WILL
;	PRODUCE AN ALL-ZERO ANSWER (ACTUALLY, IT IS COMPLETELY IDENTICALLY EQUAL TO THE
;	A-SOURCE).  HERE A LDB DOESNT GIVE SO MUCH PROBLEM SINCE
;	THE HARDWARE JUST ROTATES THE INDICATED AMOUNT AND TAKES THE LOW N BITS.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS LSH PP M-K)

XLSH  (MISC-INST-ENTRY LSH)
		(ERROR-TABLE RESTART XLSH)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 1 XLSH)
   (ERROR-TABLE ARG-POPPED 0 PP PP)
	((M-K) Q-POINTER C-PDL-BUFFER-POINTER-POP)  ;ARG2, AMT TO SHIFT
		(ERROR-TABLE RESTART XLSH0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 0 XLSH0)
	(JUMP-IF-BIT-SET BOXED-SIGN-BIT M-K XLSH1)  ;SHIFT TO RIGHT
LSH-LEFT
	((M-1) SUB (M-CONSTANT (DIFFERENCE Q-POINTER-WIDTH 1)) A-K)	;COMPUTE BYTE LENGTH <24.-SHIFT-1>
	(JUMP-LESS-THAN M-1 A-ZERO XLSH-ZERO)
#+exp	((m-tem3) add m-1 (a-constant 1))
	(POPJ-AFTER-NEXT
	 (OA-REG-LOW) DPB #+lambda M-1 #+exp m-tem3 OAL-BYTL-1 A-K)
       ((M-T) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 0 0) 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

XLSH1	(JUMP-LESS-THAN M-K
	 (A-CONSTANT (DIFFERENCE (EVAL (ASH 1 %%Q-POINTER)) (DIFFERENCE Q-POINTER-WIDTH 1)))
	 XLSH-ZERO) ;SHIFT RIGHT
	((M-TEM1) ADD M-K (A-CONSTANT (PLUS (BYTE-MASK BITS-ABOVE-FIXNUM)  ;TO SIGN EXTEND
					 40)))	; TO 32. COMPUTE 40-N .
	((M-1) ADD M-K (A-CONSTANT (PLUS (BYTE-MASK BITS-ABOVE-FIXNUM)
					 (DIFFERENCE Q-POINTER-WIDTH 1))))	;COMPUTE 24.-N-1
#+exp	((m-tem3) add m-1 (a-constant 1))
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB #+lambda M-1 #+exp m-tem3 OAL-BYTL-1 A-TEM1)
       ((M-T) BYTE-INST (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
			C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS ROT PP M-K)

XROT  (MISC-INST-ENTRY ROT)
		(ERROR-TABLE RESTART XROT)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 1 XROT)
   (ERROR-TABLE ARG-POPPED 0 PP PP)
	((M-K) Q-POINTER C-PDL-BUFFER-POINTER-POP)  ;ARG2, AMT TO ROT
		(ERROR-TABLE RESTART XROT0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 0 XROT0)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;ARG1, DATA TO ROT
XROT3 ;	*** THIS SHOULD PROBABLY LET YOU INTERRUPT AND SEQUENCE-BREAK OUT ***
	(JUMP-IF-BIT-SET BOXED-SIGN-BIT M-K XROT1)  ;ROT TO RIGHT
	(POPJ-EQUAL M-K A-ZERO)			;NO CHANGE (AVOID BYTL-1 LOSS)
	(JUMP-GREATER-OR-EQUAL M-K (A-CONSTANT Q-POINTER-WIDTH) XROT2)
;GENERAL IDEA: (1) SHIFT A 24.-N BIT PIECE N PLACES LEFT
;		    (ACTUALLY, A TRUE SHIFT OF A UNMASKED 32 BIT PIECE WOULD DO.
;		     ON THE OTHER HAND, WE HAVE THE UNSAFE BYTE POINTER PROBLEM.)
;	       (2) LDB A N BIT PIECE FROM 24-N BITS OVER
;	       (3) IOR THE TWO.
XROT3A	;REALLY DO THE WORK. BY NOW, 0 < M-K < 24.
						;DO LSH OF STEP ONE
	((M-1) SUB (M-CONSTANT (DIFFERENCE Q-POINTER-WIDTH 1)) A-K)	;COMPUTE BYTE LENGTH
;	(JUMP-LESS-THAN M-1 A-ZERO XLSH-ZERO)   ;CANT BE
#+exp	((m-tem) add m-1 (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-1 #+exp m-tem OAL-BYTL-1 A-K)
	((M-TEM3) DPB M-T (BYTE-FIELD 0 0) A-ZERO)	;PART 1 DONE
	((M-TEM2) ADD M-K (A-CONSTANT (DIFFERENCE 32. Q-POINTER-WIDTH)))	; 40-<24.-N>
	((M-ZR) SUB M-K (A-CONSTANT 1))		;BYTE LENGTH MINUS ONE
#+exp	((m-tem) add m-zr (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-ZR #+exp m-tem OAL-BYTL-1 A-TEM2)
	(POPJ-AFTER-NEXT			;PART 2 DONE
	  (M-T) BYTE-INST M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((M-T) IOR M-T A-TEM3)			;PART 3

XROT2	(JUMP-XCT-NEXT XROT3)			;LOOP UNTIL RESULT AFTER
       ((M-K) SUB M-K (A-CONSTANT Q-POINTER-WIDTH))		;SUBTRACTION IS LESS THAN 24.

;ROTATE TO RIGHT.  CONVERT TO EQUIVALENT LEFT ROTATE (24.- <-N>)
XROT1	((M-K) SELECTIVE-DEPOSIT M-K Q-POINTER (A-CONSTANT -1))	;EXTEND SIGN
	(JUMP-XCT-NEXT XROT3)
       ((M-K) ADD M-K (A-CONSTANT Q-POINTER-WIDTH))


;;; Boolean operations

QIAND
	(jump-data-type-not-equal c-pdl-buffer-pointer a-t qiand-hard)
	(jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-fix)) qiand-hard)
	(popj-after-next
	  (m-t) output-selector-mask-25 and c-pdl-buffer-pointer a-t)
       ((c-pdl-buffer-pointer) dpb m-t q-typed-pointer 
		(a-constant (byte-value q-cdr-code cdr-next)))
qiand-hard
	(JUMP-XCT-NEXT M-T-TO-CPDL)
       (CALL QIAND0)

XMAND (MISC-INST-ENTRY M-LOGAND)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Convert to Instruction calling seq
XTCAND						;MC-LINKAGE
QIAND0	((M-S) (A-CONSTANT (OA-LOW-CONTEXT (AND)))) ;An extra instruction, but saves hair
    (ERROR-TABLE RESTART QIAND0)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) PP 0 QIAND0)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-2ARG-BOOLE))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
    (ERROR-TABLE RESTART QIAND1)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-T 1 QIAND1)
    (ERROR-TABLE ARG-POPPED 0 M-T M-1)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	(POPJ-AFTER-NEXT (M-1) AND M-2 A-1)
       ((M-T) Q-POINTER M-1 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

QIIOR
	(jump-data-type-not-equal c-pdl-buffer-pointer a-t qiior-hard)
	(jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-fix)) qiior-hard)
	(popj-after-next
	  (m-t) output-selector-mask-25 ior c-pdl-buffer-pointer a-t)
       ((c-pdl-buffer-pointer) dpb m-t q-typed-pointer 
		(a-constant (byte-value q-cdr-code cdr-next)))
qiior-hard
	(JUMP-XCT-NEXT M-T-TO-CPDL)
       (CALL QIIOR0)

XMIOR (MISC-INST-ENTRY M-LOGIOR)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Convert to Instruction calling seq
XTCIOR						;MC-LINKAGE
QIIOR0	((M-S) (A-CONSTANT (OA-LOW-CONTEXT (IOR)))) ;An extra instruction, but saves hair
		(ERROR-TABLE RESTART QIIOR0)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) PP 0 QIIOR0)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-2ARG-BOOLE))
		(ERROR-TABLE RESTART QIIOR1)
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-T 1 QIIOR1)
    (ERROR-TABLE ARG-POPPED 0 M-T M-1)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	(POPJ-AFTER-NEXT (M-1) IOR M-2 A-1)
       ((M-T) Q-POINTER M-1 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

QIXOR
	(jump-data-type-not-equal c-pdl-buffer-pointer a-t qixor-hard)
	(jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-fix)) qixor-hard)
	(popj-after-next
	  (m-t) output-selector-mask-25 xor c-pdl-buffer-pointer a-t)
       ((c-pdl-buffer-pointer) dpb m-t q-typed-pointer 
		(a-constant (byte-value q-cdr-code cdr-next)))
qixor-hard
	(JUMP-XCT-NEXT M-T-TO-CPDL)
       (CALL QIXOR0)

XMXOR (MISC-INST-ENTRY M-LOGXOR)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Convert to Instruction calling seq
XTCXOR						;MC-LINKAGE
QIXOR0	((M-S) (A-CONSTANT (OA-LOW-CONTEXT (XOR)))) ;An extra instruction, but saves hair
		(ERROR-TABLE RESTART QIXOR0)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) PP 0 QIXOR0)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-2ARG-BOOLE))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
		(ERROR-TABLE RESTART QIXOR1)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-T 1 QIXOR1)
    (ERROR-TABLE ARG-POPPED 0 M-T M-1)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	(POPJ-AFTER-NEXT (M-1) XOR M-2 A-1)
       ((M-T) Q-POINTER M-1 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

;The 2nd arg of BOOLE becomes the A operand of the logical instruction.
;The 3rd arg becomes the M operand.
XBOOLE (MISC-INST-ENTRY *BOOLE)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Arg 3
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Arg 2
		(ERROR-TABLE RESTART XBOOLE)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 0 XBOOLE)
    (ERROR-TABLE ARG-POPPED 0 PP M-A M-T)
	((M-B) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((C-PDL-BUFFER-POINTER-PUSH) M-A)	;Put arg 2 back in standard place
	((M-S) DPB M-B OAL-ALUF)	;Arg 1 as OA-REG-LOW alu function
    (ERROR-TABLE RESTART XBOOLE1)
XBOOLE0	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) PP 1 XBOOLE1)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-2ARG-BOOLE))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
    (ERROR-TABLE RESTART XBOOLE2)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-T 2 XBOOLE2)
    (ERROR-TABLE ARG-POPPED 0 M-T M-1)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((OA-REG-LOW) M-S) ;ALU
	(POPJ-AFTER-NEXT (M-1) SETZ M-2 A-1)
       ((M-T) Q-POINTER M-1 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

;Boolean function of two bignums, M-S has OA-REG-LOW to do the function.
;First arg in M-Q,M-C,M-I.  Second arg in M-B/M-T,M-D,M-J.
;Eventual ACs:  small arg in M-R,M-J.  big arg in M-Q,M-I.  alu func in M-A
; result in M-T,M-C.  M-D has bit flags:
;	bit 0 - sign of smaller arg
;	bit 1 - sign of bigger arg
;This hair is required because bignums are sign-and-magnitude,
;but BOOLE wants to treat them as 2's complement.

BBOOLE	((M-TEM) BIGNUM-HEADER-SIGN M-C)	;Sign of 1st arg
	((M-A OA-REG-LOW) M-S)			;save alu func, compute sign of result
	((M-C) SETZ M-D A-C)			; in BIGNUM-HEADER-SIGN bit of M-C
	((M-D) BIGNUM-HEADER-SIGN M-D)		;bit 0 of M-D gets sign of 2nd arg
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-I A-J BBOOL0)	;Make M-Q,M-I the longer
       ((M-D) DPB M-TEM (BYTE-FIELD 1 1) A-D)	;bit 1 of M-D gets sign of 1st arg
	(DISPATCH (BYTE-FIELD 2 0) M-D D-BOOLE-REV)	;Interchange bits 0 and 1 of M-D
	 ((M-D) XOR M-D (A-CONSTANT 3))
	((M-T) M-Q)
	((M-TEM) M-J)
	((M-J) M-I)
	((M-Q) M-B)
	(JUMP-XCT-NEXT BBOOL1)
       ((M-I) M-TEM)

;If we didn't interchange the args, interchange bits 4 and 5
;of the ALU function so as to make the first argument be on the M side.
BBOOL0	(DISPATCH (BYTE-FIELD 2 4) M-A D-BOOLE-REV)
	 ((M-A) XOR M-A (A-CONSTANT 60))	;Swap bits if different
BBOOL1	((M-R) M-T)				;Small arg in M-R,M-J, big in M-Q,M-I
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 2))		;Allocate result 1 longer than bigger arg
						; due to the damned SETZ case
	((M-B) (A-CONSTANT 1))			;Index
	((A-BOOLE-CARRY-1) M-ZERO)
	((A-BOOLE-CARRY-2) M-ZERO)
BBOOL2	((VMA-START-READ) ADD M-R A-B)		;Loop over length of smaller arg
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) M-D BBOL2A)
       ((M-1) ADD READ-MEMORY-DATA A-BOOLE-CARRY-1)
	((M-1) SUB M-ZERO A-1)			;Smaller arg negative, get 2's comp form
	((A-BOOLE-CARRY-1) (BYTE-FIELD 1 31.) M-1)
BBOL2A	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 1) M-D BBOL2B)
       ((M-2) ADD READ-MEMORY-DATA A-BOOLE-CARRY-2)
	((M-2) SUB M-ZERO A-2)			;Larger arg negative, get 2's comp form
	((A-BOOLE-CARRY-2) (BYTE-FIELD 1 31.) M-2)
BBOL2B	((OA-REG-LOW) M-A) ;ALU
	((WRITE-MEMORY-DATA) SETZ M-2 A-1)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 31. 0) WRITE-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-LESS-THAN-XCT-NEXT M-B A-J BBOOL2)
       ((M-B) ADD M-B (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-B A-I BBOOL5)
       ((M-1) SUB M-ZERO A-BOOLE-CARRY-1)	;Sign bits for smaller arg
BBOOL3	((VMA-START-READ) ADD M-Q A-B)		;Do bigger arg against sign of smaller
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 1) M-D BBOL3B)
       ((M-2) ADD READ-MEMORY-DATA A-BOOLE-CARRY-2)
	((M-2) SUB M-ZERO A-2)			;Larger arg negative, get 2's comp form
	((A-BOOLE-CARRY-2) (BYTE-FIELD 1 31.) M-2)
BBOL3B	((OA-REG-LOW) M-A) ;ALU
	((WRITE-MEMORY-DATA) SETZ M-2 A-1)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 31. 0) WRITE-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-LESS-THAN-XCT-NEXT M-B A-I BBOOL3)
       ((M-B) ADD M-B (A-CONSTANT 1))
BBOOL5	((M-2) SUB M-ZERO A-BOOLE-CARRY-2)	;Sign bits for larger arg
	((OA-REG-LOW) M-A) ;ALU			;High result word comes from sign bits
	((WRITE-MEMORY-DATA) SETZ M-2 A-1)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 31. 0) WRITE-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-I) ADD M-I (A-CONSTANT 1))		;Actual length of result (for BIGNEG)
	(CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGNEG)	;Magnitude of negative result
	(JUMP BIGNUM-DPB-CLEANUP)		;Dispose of any unnecessary high words

(LOCALITY D-MEM)
(START-DISPATCH 2 (PLUS P-BIT R-BIT)) ;Skip if bits the same
D-BOOLE-REV
	(INHIBIT-XCT-NEXT-BIT)	;Bits same, no need to swap
	(0)			;Bits different, swap by XOR'ing
	(0)			;different
	(INHIBIT-XCT-NEXT-BIT)	;same
(END-DISPATCH)
(LOCALITY I-MEM)

;Mixed-mode cases...
;Bignum arg in M-Q,M-C,M-I.  Fixnum unpacked in M-2.  ALU function in M-S.
;The first arg goes on the A side, and we want the fixnum on the A side.
BFXBOOLE	;Fixnum second arg, take as first by switching ALU function
	(DISPATCH (BYTE-FIELD 2 4) M-S D-BOOLE-REV)
	 ((M-S) XOR M-S (A-CONSTANT 60))
FXBBOOLE
	((M-A) M-S)				;Stash function in M-A
	((M-D) BIGNUM-HEADER-SIGN M-C)		;M-D bit 1 gets sign of bigger arg
	((M-D) DPB M-D (BYTE-FIELD 1 1))
#+lambda((OA-REG-HIGH) (BYTE-FIELD 1 31.) M-2)	;Get sign bits for smaller arg
#+exp	((m-1) (byte-field 1 31.) m-2)
#+exp	((oa-reg-high) dpb m-1 oah-m-src a-zero)
	((M-1) M-ZERO)
	((OA-REG-LOW) M-A) ;ALU			;Compute sign of result
	((M-C) SETZ M-C A-1)
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 2))		;Allocate result one longer than bignum arg
						; due to the damned SETZ case
	((A-BOOLE-CARRY-2) M-ZERO)
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))	;Combine low word with fixnum arg
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 1) M-D BBOLFX)
       ((M-TEM) ADD READ-MEMORY-DATA A-BOOLE-CARRY-2)
	((M-TEM) SUB M-ZERO A-TEM)		;Larger arg negative, get 2's comp form
	((A-BOOLE-CARRY-2) (BYTE-FIELD 1 31.) M-TEM)
BBOLFX	((OA-REG-LOW) M-A) ;ALU
	((WRITE-MEMORY-DATA) SETZ M-TEM A-2)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 31. 0) WRITE-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-I (A-CONSTANT 2) BBOOL3)	;do more of bignum arg
       ((M-B) (A-CONSTANT 2))
	(JUMP BBOOL5)				;bignum arg only 1 word long

;;; Arithmetic shift.  Unlike LSH, ASH works on bignums

XASH (MISC-INST-ENTRY ASH)
		(ERROR-TABLE RESTART XASH)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)	;arg 2, shift count
    (ERROR-TABLE ARGTYP FIXNUM PP 1 XASH)
    (ERROR-TABLE ARG-POPPED 0 PP PP)
	((m-zr) q-data-type c-pdl-buffer-pointer)	;its theoritically possible for this value
			;to get to xdpb1 and determine whether we return dtp-fix or dtp-character.
	((M-2) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)  ;M-2 gets arg 2
		(ERROR-TABLE RESTART XASH1)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)	;arg 1, number to shift
    (ERROR-TABLE ARGTYP NUMBER PP 0 XASH1)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-1ARG-ASH))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	;Fixnum case
#+lambda((OA-REG-HIGH) (BYTE-FIELD 1 31.) M-1)	;M-3 gets sign extension of M-1
#+exp	((m-3) ldb (byte-field 1 31.) m-1)
#+exp	((oa-reg-high) dpb m-3 oah-m-src a-zero)
	((M-3) M-ZERO)
	(JUMP-GREATER-THAN M-2 A-ZERO XASH2)	;Jump if left shift
	((M-2) ADD M-2 (A-CONSTANT 40))		;Number of bits preserved by right shift
	(JUMP-GREATER-THAN M-2 A-ZERO XASH1)
	((M-2) (A-CONSTANT 1))			;Shifting too far, preserve only sign
XASH1	((M-4) SUB M-2 (A-CONSTANT 1))		;Byte size -1
#+exp	((m-tem3) add m-4 (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-4 #+exp m-tem3 OAL-BYTL-1 A-2)	;Use byte hardware
	((M-1) (BYTE-FIELD 0 0) M-1 A-3)	;Do the right arithmetic shift
	(DISPATCH-POPJ-XCT-NEXT (I-ARG 0) 
	 (BYTE-FIELD 2 (DIFFERENCE Q-POINTER-WIDTH 1))
	 M-1 D-FXOVCK)
       ((M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;Left ASH of a fixnum turns into DPB.
XASH2	((C-PDL-BUFFER-POINTER-PUSH M-4)	;Put arg 1 back on pdl
		Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-1) SELECTIVE-DEPOSIT M-3
	 (BYTE-FIELD (DIFFERENCE 33. Q-POINTER-WIDTH)
		     (DIFFERENCE Q-POINTER-WIDTH 1))
	 A-ZERO)	;background to DPB into (signs)
	((M-K) (A-CONSTANT (DIFFERENCE Q-POINTER-WIDTH 1)))		;Byte size
	;Jump if fit in machine word after shift,
	(JUMP-LESS-THAN-XCT-NEXT M-2 (A-CONSTANT (DIFFERENCE 32. Q-POINTER-WIDTH)) ASHDPB)
       ((M-E) M-2)				;Byte position
	((M-1) M-ZERO)				;Bignum, DPB into background of zero
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-3 A-ZERO ASHDPB1) ;if positive
       ((M-C) DPB M-3 BIGNUM-HEADER-SIGN A-ZERO)
	(JUMP-NOT-EQUAL-XCT-NEXT M-4		;If negative, do magic things that work
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) POSITIVE-SETZ))
		XASH3)
       ((M-4) SUB M-ZERO A-4)			;Make it positive
	((M-4) DPB (M-CONSTANT -1)
	 (BYTE-FIELD 1 (DIFFERENCE Q-POINTER-WIDTH 2)) A-ZERO)	;Divide SETZ by 2
	((M-E) ADD M-E (A-CONSTANT 1))		; and increase shift
XASH3	(CALL-XCT-NEXT ASHDPB2)
       ((C-PDL-BUFFER-POINTER) Q-POINTER M-4
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	;; Note that we don't 2's complement it back again.
	(JUMP BIGNUM-DPB-CLEANUP)

;ASH of a bignum, in M-Q,M-C,M-I.  M-2 shift distance.
BIGASH	(JUMP-EQUAL M-2 A-ZERO RETURN-M-Q)	;Code below doesn't work for shift of 0
	((M-1 MD) M-2)
	(CALL-XCT-NEXT DIV)			;Split shift into words and bits
       ((M-2) (A-CONSTANT 31.))			;Q-R gets number of words, M-1 gets bits
	(JUMP-LESS-THAN MD A-ZERO BIGASHR)	;Jump if right shift
	(JUMP-NOT-EQUAL M-1 A-ZERO BIGASH3)	;Make BIDIV-NORMALIZE work, cannot shift by 0
	((M-1) (A-CONSTANT 31.))		;so shift by 31. bits and one less word.  This
	((Q-R) SUB Q-R (A-CONSTANT 1))		;depends on DPB with IR<9:0>=-1 generating 0.
BIGASH3	((M-R) Q-R)				;Number of words of shifting
	((M-J) A-ZERO)				;No words discarded
BIGASH2	((M-B) ADD Q-R A-I)			;Result length is number of zero words shifted
	(CALL-XCT-NEXT BNCONS)			; in at bottom, + arg length, +1 at top
       ((M-B) ADD M-B (A-CONSTANT 2))		; for bits shift, +1 for header
	((M-E) M-R)				;Number of zero words at bottom
	(CALL-XCT-NEXT BIDIV-NORMALIZE-ENCODE-SHIFT)	;Encode bit shift from M-1
       ((M-1) M-A-1 (M-CONSTANT 32.) A-1)
	((M-ZR) ADD M-I A-J)			;Number of words to read from old bignum
	((M-B) SUB M-Q A-J)			;Address of old bignum (offset if right shift)
	((M-B) Q-POINTER M-B)			;Avoid illegal pointer lying around
	((M-D) M-T)				;Address of new bignum
	(CALL-XCT-NEXT BIDIV-NORMALIZE)		;Shift subroutine
       ((M-2) A-ZERO)				;0 bits in at top
	(JUMP BIGNUM-DPB-CLEANUP)		;Fix bignum length and return

BIGASHR	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGASHR-NEGATIVE)
	((M-R) (A-CONSTANT -1))			;Bottom word of left-shift result discarded
	((M-J) Q-R)				;Negative number of words discarded at
						; bottom of input bignum
	((M-1) ADD M-1 (A-CONSTANT 31.))	;Convert right bit shift into left shift
	((Q-R) SUB M-J (A-CONSTANT 1))		;Cause M-B (to cons) to match M-ZR (to norm)
	((M-TEM) ADD M-J A-I)
	(JUMP-GREATER-THAN M-TEM A-ZERO BIGASH2)	;Jump if any significance
#+lambda((OA-REG-HIGH) BIGNUM-HEADER-SIGN M-C)	;Result is just sign bits
#+exp	((m-1) bignum-header-sign m-c)
#+exp	((oa-reg-high) dpb m-1 oah-m-src a-zero)
	((M-1) M-ZERO)
	(DISPATCH-POPJ-XCT-NEXT (I-ARG 0) 
	 (BYTE-FIELD 2 (DIFFERENCE Q-POINTER-WIDTH 1))
	 M-1 D-FXOVCK)
       ((M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;Fix up for the difference between right-shift and division on negative numbers.
BIGASHR-NEGATIVE
	((PDL-PUSH) DPB MD Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	;; Compute a positive bignum which would be the 1's complement of the original
	;; if bignums were stored in 2's complement: minus the original, minus one.
	;; Shifting commutes with 1's complementing, and shifting this
	;; positive bignum works right.
	((PDL-PUSH) DPB M-MINUS-ONE Q-POINTER
		    (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-T) M-Q)
	(CALL QISUB)
	;; Shift that the desired amount.
	((M-T) PDL-POP)
	((M-2) PDL-POP)
	((PDL-PUSH) M-T)
	((PDL-PUSH) M-2)
	(CALL XASH)
	;; 1's complement the result, getting the desired value.
	((PDL-PUSH) DPB M-MINUS-ONE Q-POINTER
		    (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL QISUB)	
	(POPJ-XCT-NEXT)
       ((M-T) PDL-POP)

;ASH of a flonum is FSC, i.e. multiply by appropriate power of 2
FLONUM-ASH
	(POPJ-AFTER-NEXT (M-I) ADD M-I A-2)	;Add shift count to exponent
       (NO-OP)
))