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

(DEFCONST UC-ARITH '(
;;; NON-DESTINATION GROUP 1
;   E IN VMA, C(E) IN M-T, MOSTLY EXIT BY PUTTING RESULT ON STACK

;GET TWO PDL ARGUMENTS, FIRST TO M-1, SECOND TO M-2

FXGTPP	  (ERROR-TABLE RESTART FXGTPP)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		;GET PDL ARG
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	  (ERROR-TABLE ARGTYP FIXNUM PP 1 FXGTPP)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	  (ERROR-TABLE RESTART FXGTP0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
	  (ERROR-TABLE ARGTYP FIXNUM PP 0 FXGTP0)
	  (ERROR-TABLE ARG-POPPED 0 PP M-T)
	(POPJ-AFTER-NEXT
	  (M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
       ((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)

;FIXGET, FIXGET-1 not used on LAMBDA.


;;; MULTIPLY SUBROUTINE
;M-1 TIMES Q-R, RESULT TO Q-R, LEAVES CORRECT HIGH HALF IN M-2.
;CALLER MUST CHECK FOR OVERFLOW, IF SHE CARES.

MPY	((M-2) MULTIPLY-STEP A-1 M-ZERO)
(REPEAT 30. ((M-2) MULTIPLY-STEP M-2 A-1))
	(POPJ-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) Q-R)
       ((M-2) MULTIPLY-STEP M-2 A-1)
	(POPJ-AFTER-NEXT
	 (M-2) M-2 SUB A-1)		;FINAGLE IF NEGATIVE VALUE INITIALLY IN Q-R
       (NO-OP)

;;; DIVIDE SUBROUTINE
;   DIVIDEND IN M-1, DIVISOR IN M-2
;   QUOTIENT IN Q-R, REMAINDER IN M-1, CLOBBERS A-TEM1
#-lambda(begin-comment)
DIV     (declare (args a-1 a-2) (values a-1) (clobbers a-tem1))
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-1 A-ZERO DIV1)
       ((M-TEM1 Q-R) M-1)	;Q GETS MAGNITUDE OF DIVIDEND, A-TEM1 SAVES ORIGINAL
	((Q-R) SUB M-ZERO A-TEM1)
DIV1	((M-1) DIVIDE-FIRST-STEP M-ZERO A-2)
DIV1A	(CALL-IF-BIT-SET (BYTE-FIELD 1 0) Q-R TRAP)	;DIVIDE OVERFLOW
  (ERROR-TABLE DIVIDE-BY-ZERO)
(REPEAT 31. ((M-1) DIVIDE-STEP M-1 A-2))
	((M-1) DIVIDE-LAST-STEP M-1 A-2)
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-ZERO A-TEM1 DIV2) ;JUMP IF POSITIVE DIVIDEND
       ((M-1) DIVIDE-REMAINDER-CORRECTION-STEP M-1 A-2) ;M-1 GETS MAGNITUDE OF REMAINDER
	((M-1) SUB M-ZERO A-1)		;NEGATIVE DIVIDEND => NEGATIVE REMAINDER
DIV2	((M-TEM1) XOR M-2 A-TEM1)	;IF SIGNS OF DIVIDEND AND DIVISOR ARE DIFFERENT,
	(POPJ-LESS-OR-EQUAL M-ZERO A-TEM1)
	(POPJ-AFTER-NEXT
	 (M-TEM1) Q-R)
       ((Q-R) SUB M-ZERO A-TEM1)	;THEN QUOTIENT IS NEGATIVE
#-lambda(end-comment)

#-exp(begin-comment)
DIV
	(Jump-greater-or-equal-xct-next M-1 A-Zero DIV1)
       ((M-TEM1 Q-R) M-1)
	((Q-R) SUB M-Zero A-tem1)
DIV1
#-exp(begin-comment)
	(Jump-greater-or-equal-xct-next M-2 A-Zero DIV-Not-Neg-2)
       ((m-tem2) M-2)
	((M-2) SUB M-Zero A-2)
DIV-Not-Neg-2
#-exp(end-comment)
	((M-1) Divide-First-Step M-Zero A-2)
DIV1A	(Call-If-Bit-Set (Byte-Field 1 0) Q-R TRAP)
  (ERROR-TABLE DIVIDE-BY-ZERO)
       (repeat 31. ((M-1) Divide-Step M-1 A-2))
	((M-1) Divide-Last-Step M-1 A-2)
	(Jump-Less-Or-Equal-Xct-Next M-Zero a-tem1 DIV2)
       ((M-1) Divide-Remainder-Correction-Step M-1 A-2)
	((M-1) SUB M-Zero A-1)
DIV2
#+exp	((M-2) m-tem2)
	((m-tem1) xor m-2 a-tem1)
	(popj-less-or-equal m-zero a-tem1)
	(popj-after-next (m-tem1) Q-R)
       ((Q-R) SUB M-zero a-tem1)
#-exp(end-comment)

;FIXNUM EXPONENTIATION ROUTINE.
;M-3 HOLDS THE EXPONENT, AND GETS SHIFTED AND TESTED.
;M-1 HOLDS THE FIRST ARG, SQUARED N TIMES.
;M-T HOLDS THE PARTIAL PRODUCTS

(ERROR-TABLE DEFAULT-ARG-LOCATIONS ^ PP PP)

XUPARROW (MISC-INST-ENTRY ^)
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 1))	;POINT TO FIRST ARG
	(jump-data-type-not-equal c-pdl-buffer-index
		 (a-constant (byte-value q-data-type dtp-fix)) xupout)
	(jump-data-type-not-equal c-pdl-buffer-pointer
		 (a-constant (byte-value q-data-type dtp-fix)) xupout)
	((m-2) output-selector-extend-25 c-pdl-buffer-pointer)
	((m-1) output-selector-extend-25 c-pdl-buffer-index)
	(JUMP-LESS-THAN M-2 A-ZERO XUP6)		;FIXNUM ^ -<FIXNUM> = 0 USUALLY
XUP5	((M-TEM) (A-CONSTANT 1))			;INITIALIZE RESULT
	(JUMP-EQUAL M-2 A-ZERO XUP4)			;ANYTHING ^ 0 = 1
	((M-3) M-2)					;SAVE THE EXPONENT
XUP1	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-3 XUP2)
	(CALL-XCT-NEXT MPY)				;M-1 TIMES M-TEM TO Q-R
       ((Q-R) M-TEM)
	((M-2) SELECTIVE-DEPOSIT Q-R
	 (BYTE-FIELD (DIFFERENCE 33. Q-POINTER-WIDTH)
		     (DIFFERENCE Q-POINTER-WIDTH 1))
	 A-2)	;DISCARDED BITS AND SIGN
							;M-TEM IS 32 BITS, BUT FIXED BIN(23,0)
	(JUMP-EQUAL-XCT-NEXT M-2 A-ZERO XUP2)		;JUMP IF POSITIVE NO OVERFLOW
       ((M-TEM) Q-R)					;PRODUCT BACK TO M-TEM
	(JUMP-NOT-EQUAL M-2 (A-CONSTANT -1) XUPOUT)	;DROP THROUGH IF OK NEG, ELSE OVFL
XUP2	((M-3) M-3 OUTPUT-SELECTOR-RIGHTSHIFT-1)	;(SETQ M-3 (ASH M-3 -1))
	(JUMP-EQUAL M-3 A-ZERO XUP4)			;IF ZERO, RESULT IS IN M-TEM
	(CALL-XCT-NEXT MPY)				;OTHERWISE COMPUTE NEXT POWER
       ((Q-R) M-1)					;I.E. Q-R GETS M-1 TIMES M-1
	((M-2) SELECTIVE-DEPOSIT Q-R
	 (BYTE-FIELD (DIFFERENCE 33. Q-POINTER-WIDTH)
		     (DIFFERENCE Q-POINTER-WIDTH 1))
	 A-2)	;DISCARDED BITS AND SIGN
	(JUMP-NOT-EQUAL M-2 A-ZERO XUPOUT)		;OVERFLOW (RESULT IS ALWAYS POSITIVE)
	(JUMP-XCT-NEXT XUP1)
       ((M-1) Q-R)					;(SETQ M-1 (* M-1 M-1))

;;; Here if exponent is a negative integer.
;Result is a rational unless base (M-1) is 0, -1, or 1.
XUP6	(JUMP-GREATER-THAN M-1 (A-CONSTANT 1) XUP3)
	(JUMP-LESS-THAN M-1 (A-CONSTANT -1) XUP3)
	(CALL-EQUAL M-1 (A-CONSTANT 0) TRAP)		;0 ^ negative power is an error
	    (ERROR-TABLE DIVIDE-BY-ZERO)
	((M-TEM) M-1)
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) M-2 XUP4)	;-1 ^ odd negative power is -1
	((M-TEM) (A-CONSTANT 1))			;-1 ^ even negative power is 1
	;drop into XUP4
;;; RETURN VALUE IN M-TEM AND POP OFF ARGUMENTS
XUP4	(POPJ-AFTER-NEXT (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
       ((M-T) DPB M-TEM Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

XUP3	((M-2) SUB M-ZERO A-2)	;Make the exponent positive.
        ;Make exponent on stack positive as well -- if we overflow, will call-out to macrocode with original arguments
        ((c-pdl-buffer-pointer) dpb m-2 q-pointer (a-constant (byte-value q-data-type dtp-fix)))
	(CALL XUP5)		;Exponentiate.
	((PDL-PUSH) M-T)	;This becomes the denominator.  The numerator is 1.
	(JUMP-IF-BIT-SET BOXED-SIGN-BIT M-T XUP3A)	;But may need to factor out -1.
	((PDL-PUSH) DPB M-MINUS-ONE (BYTE-FIELD 1 0) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(JUMP MAKE-RATIONAL)

XUP3A	(CALL XABS)		;Here for reciprocal of negative integer: make it positive
	((PDL-PUSH) M-T)	;and make rational with numerator -1.
	((PDL-PUSH) DPB M-MINUS-ONE Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(JUMP MAKE-RATIONAL)

;;; HERE CALL OUT TO MACRO CODE
XUPOUT	((M-A) C-PDL-BUFFER-POINTER-POP)	;The exponent
	((M-B) C-PDL-BUFFER-POINTER-POP)	;The base
	(CALL P3ZERO)				;Open micro-to-macro call
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-EXPT))	;Get fctn cell of EXPT-HELP
	(DISPATCH TRANSPORT MD)
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push function
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the base
		Q-TYPED-POINTER M-B (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the exponent
		Q-TYPED-POINTER M-A (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-JUMP MMJCALL) (I-ARG 2))		;Call it tail-recursively


XGCD (MISC-INST-ENTRY INTERNAL-\\)		;GCD, STEIN'S ALGORITHM.
	(CALL-XCT-NEXT GET-FIX-OR-BIGNUM)	; SET UP FOR GCD'S BY GETTING 2 ARGS
       ((M-A) M-ZERO)				;THIS IS MAGIC INDEX ON TYPES OF ARGUMENTS
	(DISPATCH (BYTE-FIELD 2 0) M-A GCD-DISPATCH)

(LOCALITY D-MEM)
(START-DISPATCH 2)
GCD-DISPATCH
	(P-BIT R-BIT)		;FIXNUM-FIXNUM CASE (DROPS THROUGH)
	(INHIBIT-XCT-NEXT-BIT GCD-FIX-BIG)	;FIXNUM-BIGNUM CASE
	(INHIBIT-XCT-NEXT-BIT GCD-BIG-FIX)	;BIGNUM-FIXNUM CASE
	(INHIBIT-XCT-NEXT-BIT GCD-BIG-BIG)	;BIGNUM-BIGNUM CASE
(END-DISPATCH)
(LOCALITY I-MEM)

;;; DROP THROUGH ON FIX-FIX CASE (ARGUMENTS IN M-1 M-2)
;;; Clobbers M-1, M-2, M-A, Q-R, M-TEM, A-TEM1.
GCD-FIX-FIX
#+lambda((M-A Q-R) (A-CONSTANT (LOGAND 7777  ;ASSURE SAVE FOR TYPED REGISTER
				       (OA-LOW-CONTEXT ((BYTE-FIELD 32. 0))))))
#+exp	((m-a q-r) (a-constant 0)) ;byte-length & rot field for all bits, no shift
	(JUMP-GREATER-OR-EQUAL M-1 A-ZERO XGCD0)	;TAKE ABS OF ARGS
	((M-1) SUB M-ZERO A-1)
XGCD0	(JUMP-GREATER-OR-EQUAL M-2 A-ZERO XGCDL)
	((M-2) SUB M-ZERO A-2)
XGCDL	(JUMP-EQUAL M-2 A-ZERO XGCD5)
	(JUMP-GREATER-THAN M-1 A-2 XGCD1)
	((M-TEM) M-1)		;EXCHANGE ARGS SO M-1 IS THE BIGGER
	((M-1) M-2)
	((M-2) M-TEM)
XGCD1	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) M-1 XGCD2)
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) M-2 XGCD3)
	((M-A) SUB M-A (A-CONSTANT 37))			;BOTH EVEN
							;ADD1 TO ROTATE FIELD, SUB1 FROM LENGTH
        ((M-2) M-2 OUTPUT-SELECTOR-RIGHTSHIFT-1)
XGCD3	(JUMP-XCT-NEXT XGCDL)				;M-1 EVEN
       ((M-1) M-1 OUTPUT-SELECTOR-RIGHTSHIFT-1)

XGCD2	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) M-2 XGCD4)
	(JUMP-XCT-NEXT XGCDL)				;M-2 EVEN
       ((M-2) M-2 OUTPUT-SELECTOR-RIGHTSHIFT-1)

XGCD4	((M-TEM) M-2)		;BOTH ODD
	((M-2) SUB M-1 A-2)
	(JUMP-XCT-NEXT XGCDL)
       ((M-1) M-TEM)

XGCD5
#+exp	((m-tem3) add m-a (a-constant 1_5))
		;Final shifting step
#+exp	((OA-REG-LOW) (Byte-Field 10. 0) M-A)
#+lambda((oa-reg-low) m-a)
	((M-1) DPB M-1 (BYTE-FIELD 0 0) A-ZERO)
	(JUMP RETURN-M-1)

;BIGNUM GCD MOVED TO UC-HACKS FILE.

;;;This takes a stream of 31. bit words and right justifies it
;;; into the bignum in M-S. You hand words in in M-2.
;;; After each call M-E "points" to the location about to be stored into or 0
;;; if no ones have been found, M-3 is the number of 31. bit words of zeros skipped,
;;; M-4 is the number of bits skipped mod 31. M-A and M-B are used for internal
;;; constants for ldbing and dpbing. Temporary things are kept in M-1 as well
;;; Inits: ((M-E) A-ZERO)	;flags that no 1s have been found.
;;;	   ((M-3) A-MINUS-ONE)	;Actually init to anything you want, it will be
;;;				; incremented N+1 times.
BIGNUM-RIGHT-JUST
	(JUMP-EQUAL M-E A-ZERO BIGNUM-RIGHT-JUST-FFO)
	(JUMP-EQUAL M-4 A-ZERO BIGNUM-RIGHT-JUST-PUNT)
#+exp	((m-tem3) add m-a (a-constant 1_5))
#+exp	((oa-reg-low) ldb (byte-field 10. 0) m-tem3)
#+lambda((OA-REG-LOW) M-A)
	((MD) DPB M-2 (BYTE-FIELD 0 0) A-1)
	((VMA-START-WRITE) ADD M-S A-E)
	(CHECK-PAGE-WRITE-UNBOXED)
#+exp	((m-tem3) add m-b (a-constant 1_5))
#+exp	((oa-reg-low) ldb (byte-field 10. 0) m-tem3)
#+lambda((OA-REG-LOW) M-B)
	(POPJ-AFTER-NEXT (M-1) (BYTE-FIELD 0 0) M-2 A-ZERO)
       ((M-E) ADD M-E (A-CONSTANT 1))

BIGNUM-RIGHT-JUST-PUNT
	((MD) M-1)
	((VMA-START-WRITE) ADD M-S A-E)
	(CHECK-PAGE-WRITE-UNBOXED)
	(POPJ-AFTER-NEXT (M-1) M-2)
       ((M-E) ADD M-E (A-CONSTANT 1))

BIGNUM-RIGHT-JUST-FFO
	(POPJ-EQUAL-XCT-NEXT M-2 A-ZERO)
       ((M-3) ADD M-3 (A-CONSTANT 1))
	((M-E) (A-CONSTANT 1))
	((M-4) A-MINUS-ONE)
	((M-2) DPB M-2 (BYTE-FIELD 31. 1) A-ZERO)
BIGNUM-RIGHT-JUST-FFO-1
	((M-2) (BYTE-FIELD 31. 1) M-2 A-ZERO)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) M-2 BIGNUM-RIGHT-JUST-FFO-1)
       ((M-4) ADD M-4 (A-CONSTANT 1))
	((M-1) M-2)
	;;Now for DPB (M-A) we need BYTL-1 = M-4 - 1   and MROT = 31. - M-4
	;;and for LDB (M-B) we need BYTL-1 = 30. - M-4 and MROT = 32. - M-4
	((M-TEM) (A-CONSTANT 30.))
	((M-TEM) SUB M-TEM A-4)			; 30. - M-4
	((M-A) ADD M-TEM (A-CONSTANT 1))
	((M-B) ADD M-TEM (A-CONSTANT 2))
#+exp	((M-TEM) M+1 M-TEM)
	((M-B) DPB M-TEM OAL-BYTL-1 A-B)
	(POPJ-AFTER-NEXT (M-TEM) SUB M-4 #+lambda (A-CONSTANT 1) #+exp a-zero)
       ((M-A) DPB M-TEM OAL-BYTL-1 A-A)

XREM (MISC-INST-ENTRY \)
	(CALL-XCT-NEXT XFLOOR-2-A)
       ((M-1) (A-CONSTANT 2))				;TRUNCATE opcode.
	(POPJ-AFTER-NEXT
	  (M-T) Q-TYPED-POINTER PDL-POP)
       ((M-GARBAGE) PDL-POP)

;	(CALL-XCT-NEXT GET-FIX-OR-BIGNUM)
;       ((M-A) M-ZERO)
;	(DISPATCH (BYTE-FIELD 2 0) M-A REMAINDER-DISPATCH)
;;;; DROP THROUGH ON FIX-FIX CASE
;REMAINDER-FIX-FIX
;	(CALL DIV)
;XREM1	(POPJ-AFTER-NEXT
;	 (M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
;       (NO-OP)

;(LOCALITY D-MEM)
;(START-DISPATCH 2)
;REMAINDER-DISPATCH
;	(P-BIT R-BIT)		;FIXNUM-FIXNUM CASE (DROPS THROUGH)
;	(INHIBIT-XCT-NEXT-BIT REMAINDER-FIX-BIG)	;FIXNUM-BIGNUM CASE
;	(INHIBIT-XCT-NEXT-BIT REMAINDER-BIG-FIX)	;BIGNUM-FIXNUM CASE
;	(INHIBIT-XCT-NEXT-BIT REMAINDER-BIG-BIG)	;BIGNUM-BIGNUM CASE
;(END-DISPATCH)
;(LOCALITY I-MEM)

;;;; THE VALUE IS ALWAYS THE FIXNUM EXCEPT WHEN THE FIXNUM IS "SETZ" AND THE BIGNUM IS
;;;; POSITIVE "SETZ", IN WHICH CASE THE ANSWER IS 0 (THIS DEPENDS ON THE HEADER FOR THE
;;;; BIGNUM BEING IN MD)
;REMAINDER-FIX-BIG
;	(POPJ-NOT-EQUAL-XCT-NEXT M-2 (A-CONSTANT NEGATIVE-SETZ))
;       ((M-T) M-C)			;RESULT IS THE FIXNUM, USUALLY
;	((M-1) BIGNUM-HEADER-LENGTH MD)	;GET THE LENGTH OF THE BIGNUM
;	(POPJ-NOT-EQUAL M-1 (A-CONSTANT 1))
;	((VMA-START-READ) ADD M-B (A-CONSTANT 1))	;READ THE BIGNUM
;	(CHECK-PAGE-READ)
;	(POPJ-AFTER-NEXT
;	  POPJ-NOT-EQUAL MD (A-CONSTANT POSITIVE-SETZ))
;       ((M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;RESULT IS 0

;;; HERE THE BIGNUM IS IN M-B, FIXNUM IN M-2
;;; M-1 IS USED FOR ACCUMULATOR M-B IS THE POINTER TO THE
;;; BIGNUM, M-C IS THE LOOP COUNTER (INITED WITH THE LENGTH OF THE BIGNUM) (ALSO OFFSET)
;;; M-A IS THE SIGN BIT OF THE BIGNUM
;;; REMAINDER MUST BE LEFT IN M-1 FOR THE SAKE OF GCD-BIG-FIX AND REMAINDER-BIG-BIG
;;;People will want to call REMAINDER-BIG-FIX-1 with a fixnum in M-2 a bignum in M-B
;;; its length in M-C and sign bit in the low bit of M-A. REMAINDER-BIG-FIX-1 Doesn't
;;; work if the fixnum is 0! (You must deal with that yourself.)
REMAINDER-BIG-FIX
	(JUMP-EQUAL M-2 A-ZERO RETURN-M-B)
	((M-C) BIGNUM-HEADER-LENGTH MD)
	((M-A) BIGNUM-HEADER-SIGN MD)
REMAINDER-BIG-FIX-1
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-2 A-ZERO REM-BIG-FIX-LOOP)
       ((M-1) SETZ)
	((M-2) SUB M-ZERO A-2)		;TAKE ABS OF DIVISOR
REM-BIG-FIX-LOOP
	((VMA-START-READ) ADD M-B A-C)
	(CHECK-PAGE-READ)
	((M-TEM1) SETZ)			;IMPLICIT ARGUMENT TO DIV1A
	((M-TEM) DPB M-1 (BYTE-FIELD 1 31.) A-ZERO)
	((Q-R) ADD MD A-TEM)
	(JUMP-IF-BIT-SET-XCT-NEXT (BYTE-FIELD 1 31.) M-TEM REM-BIG-FIX-OVFL)
       ((M-1) (BYTE-FIELD 31. 1) M-1)
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 31.) Q-R REM-BIG-FIX-OVFL)
	((M-1) ADD M-1 (A-CONSTANT 1))
;;; HERE M-1,,Q-R HAVE (M-1)*1_31.+MD
REM-BIG-FIX-OVFL
#-exp(begin-comment)
	(Jump-greater-or-equal-xct-next M-2 A-Zero REM-BIG-FIX-Not-Neg-2)
       ((m-tem2) M-2)
	((M-2) SUB M-Zero A-2)
REM-BIG-FIX-Not-Neg-2
#-exp(end-comment)
	(CALL-XCT-NEXT DIV1A)
       ((M-1) DIVIDE-FIRST-STEP M-1 A-2)
	(JUMP-NOT-EQUAL-XCT-NEXT M-C (A-CONSTANT 1) REM-BIG-FIX-LOOP)
       ((M-C) SUB M-C (A-CONSTANT 1))
	(POPJ-EQUAL-XCT-NEXT M-A A-ZERO)	;POPJ IF DIVIDEND POSITIVE
       ((M-T) DPB Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(POPJ-AFTER-NEXT (M-1) SUB M-ZERO A-1)
       ((M-T) DPB Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

RETURN-M-B
 	(POPJ-AFTER-NEXT (M-T) M-B)
       (NO-OP)

;;; RETURNS IN M-A BITS SAYING WHAT THE TWO ARGUMENTS ARE (FOR \ AND \\)
;;; IN FIXNUM-FIXNUM CASE RETURNS M-A UNCHANGED (0) AND FIXNUMS IN M-1 AND M-2 (SECOND)
;;; IN THE BIGNUM-FIXNUM AND FIXNUM-BIGNUM CASE, IT RETURNS THE FIXNUM IN M-2 AND THE
;;; BIGNUM IN M-B. IN THE BIGNUM-BIGNUM CASE, IT RETURNS THE BIGNUMS IN M-B AND M-C
;;; IN ANY CASE M-T IS THE SECOND ARGUMENT, M-C IS THE FIRST
GET-FIX-OR-BIGNUM
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-1) SELECTIVE-DEPOSIT M-T Q-DATA-TYPE A-ZERO)
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
			GET-ANY-BIG)
       ((M-C) C-PDL-BUFFER-POINTER-POP)
GET-ANY-CHAR
#+lambda((OA-REG-HIGH) BOXED-SIGN-BIT M-T)		;SIGN EXTEND (MUNG M SOURCE)
#+exp	((m-tem3) boxed-sign-bit m-t)
#+exp	((oa-reg-high) dpb m-tem3 oah-m-src a-zero)
	((M-2) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-T)
	((M-1) SELECTIVE-DEPOSIT M-C Q-DATA-TYPE A-ZERO)
	(JUMP-NOT-EQUAL M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) GET-BIG-FIX)
GET-CHAR-FIX
#+lambda(POPJ-AFTER-NEXT
	 (OA-REG-HIGH) BOXED-SIGN-BIT M-C)		;SIGN EXTEND (MUNG M SOURCE)
#+exp	((m-tem3) boxed-sign-bit m-c)
#+exp	(popj-after-next (oa-reg-high) dpb m-tem3 oah-m-src a-zero)
       ((M-1) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-C)
GET-FIX-ANY
#+lambda(POPJ-AFTER-NEXT
	 (OA-REG-HIGH) BOXED-SIGN-BIT M-C)		;SIGN EXTEND (MUNG M SOURCE)
#+exp	((m-tem3) boxed-sign-bit m-c)
#+exp	(popj-after-next (oa-reg-high) dpb m-tem3 oah-m-src a-zero)
       ((M-2) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-C)

GET-BIG-FIX
	(JUMP-EQUAL M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CHARACTER)) GET-CHAR-FIX)
	((M-A) (A-CONSTANT 2))
	(CALL-XCT-NEXT ASSURE-BIGNUM)
       ((M-I) M-C)
    (ERROR-TABLE ARG-POPPED 0 M-C M-T)
	(POPJ-AFTER-NEXT
	 (M-C) M-I)
       ((M-B) M-I)

GET-ANY-BIG
	(JUMP-EQUAL M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CHARACTER))
		    GET-ANY-CHAR)
	((M-A) (A-CONSTANT 1))
	(CALL-XCT-NEXT ASSURE-BIGNUM)
       ((M-I) M-T)
    (ERROR-TABLE ARG-POPPED 0 M-C M-T)
	((M-T) M-I)
	((M-1) SELECTIVE-DEPOSIT M-C Q-DATA-TYPE A-ZERO)
	(JUMP-EQUAL-XCT-NEXT M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
			GET-FIX-ANY)
       ((M-B) M-T)		;THIS IS THE SECOND ARGUMENT BIGNUM
	(JUMP-EQUAL M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CHARACTER))
			GET-FIX-ANY)
;;; HERE THEY ARE BIG-BIG
	((M-A) (A-CONSTANT 3))
	(CALL-XCT-NEXT ASSURE-BIGNUM)
       ((M-I) M-C)
    (ERROR-TABLE ARG-POPPED 0 M-C M-T)
	(POPJ-AFTER-NEXT
	 (M-C) M-I)
	(NO-OP)

;;;   ASSURES THAT THE HEADER NOW BEING READ INTO MD POINTS TO A LEGAL BIGNUM HEADER
;;;   VMA AND M-I CONTAIN POINTER TO THE BIGNUM
;;; NOTE: This scheme didn't check the pointer data-type until after the memory cycle
;;; started.  Since other data-types (ie: small-flonum) occasionally elide previous
;;; type-checking, this marginality was not deemed acceptable.  The code now takes the
;;; argument in M-I, which is type-checked before it is referenced.  KHS 10/13/84.
ASSURE-BIGNUM
	(CALL-DATA-TYPE-NOT-EQUAL M-I
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)) TRAP)
		(ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-I NIL)
	((VMA-START-READ) M-I)
	(CHECK-PAGE-READ)			;CHECK FOR PAGE FAULTS
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-I) VMA)		;get transported number address 
	((M-TEM) SELECTIVE-DEPOSIT MD HEADER-TYPE-FIELD A-ZERO)
	(POPJ-EQUAL M-TEM (A-CONSTANT (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM)))
	(CALL TRAP)
		(ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-I NIL)

;;; Takes a fixnum or bignum argument on the stack and returns the low-order 32
;;; bits of it in M-1.  Bashes M-I, M-J only.
GET-32-BITS  (declare (values a-1) (clobbers a-i a-j))
	(JUMP-DATA-TYPE-EQUAL C-PDL-BUFFER-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
		FXUNPK-P-1)
	(JUMP-DATA-TYPE-EQUAL C-PDL-BUFFER-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CHARACTER))
		FXUNPK-P-1)
	(CALL-XCT-NEXT ASSURE-BIGNUM)
       ((M-I) C-PDL-BUFFER-POINTER-POP)
	((M-I) BIGNUM-HEADER-LENGTH MD)
	((M-J) BIGNUM-HEADER-SIGN MD)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;Low-order word
	(CHECK-PAGE-READ)
	(JUMP-LESS-THAN-XCT-NEXT M-I (A-CONSTANT 2) GET-32-BITS-1)
       ((M-1) READ-MEMORY-DATA)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-1) DPB READ-MEMORY-DATA (BYTE-FIELD 1 31.) A-1)
GET-32-BITS-1
	(POPJ-AFTER-NEXT POPJ-EQUAL M-J A-ZERO)	
       ((M-1) SUB M-ZERO A-1)				;Negative

;;; Operations on unsigned quantities.

;TEMPORARY DOUBLE PRECISION KLUDGE.  DOESN'T CHECK FOR OVERFLOW (PRESUMABLY CAN'T ANYWAY!)
XMUL-FRACTIONS (MISC-INST-ENTRY %MULTIPLY-FRACTIONS)
	(CALL FXGTPP)
   (ERROR-TABLE CALLS-SUB %MULTIPLY-FRACTIONS)
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-2)
	(POPJ-AFTER-NEXT
	 (M-T)
	 (BYTE-FIELD (DIFFERENCE 32. Q-POINTER-WIDTH)
		     (DIFFERENCE Q-POINTER-WIDTH 0))
	 Q-R (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((M-T) DPB M-2 (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH
					      (DIFFERENCE 32. Q-POINTER-WIDTH))
				  (DIFFERENCE 32. Q-POINTER-WIDTH))
		  A-T)

XPOINTER-TIMES (MISC-INST-ENTRY %POINTER-TIMES)
	(CALL FXGTPP)
    (ERROR-TABLE CALLS-SUB %24-BIT-TIMES)
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-2)
	(POPJ-AFTER-NEXT (M-T) DPB Q-R Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

;SPECIAL NON-OVERFLOW-CHECKING FUNCTIONS FOR WEIRD HACKS
X24ADD (MISC-INST-ENTRY %24-BIT-PLUS)
	(CALL FXGTPP)
   (ERROR-TABLE CALLS-SUB %24-BIT-PLUS)
	(POPJ-AFTER-NEXT (M-1) ADD M-1 A-2)
       ((M-T) DPB M-1 (BYTE-FIELD 24. 0) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

X24SUB (MISC-INST-ENTRY %24-BIT-DIFFERENCE)
	(CALL FXGTPP)
   (ERROR-TABLE CALLS-SUB %24-BIT-DIFFERENCE)
	(POPJ-AFTER-NEXT (M-1) SUB M-1 A-2)
       ((M-T) DPB M-1 (BYTE-FIELD 24. 0) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

X24MUL (MISC-INST-ENTRY %24-BIT-TIMES)
	(CALL FXGTPP)
    (ERROR-TABLE CALLS-SUB %24-BIT-TIMES)
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-2)
	(POPJ-AFTER-NEXT (M-T) DPB Q-R (BYTE-FIELD 24. 0) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

XDIV-DOUBLE (MISC-INST-ENTRY %DIVIDE-DOUBLE)
	(CALL XDIVD1)					;CALL DOUBLE PRECISION DIVIDE
	(POPJ-AFTER-NEXT 		;DIVIDE CAN'T OVERFLOW
	 (M-T) DPB Q-R Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

XREM-DOUBLE (MISC-INST-ENTRY %REMAINDER-DOUBLE)
	(call xdivd1)
	(popj-after-next
	  (m-t) dpb m-1 q-pointer (a-constant (byte-value q-data-type dtp-fix)))
	(no-op)

;	(JUMP-XCT-NEXT XREM1)
;       (CALL XDIVD1)					;CALL DOUBLE PRECISION DIVIDE
;XREM1	(POPJ-AFTER-NEXT
;	 (M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
;       (NO-OP)

;DOUBLE PRECISION DIVIDE.  ARGS ON PDL ARE DIVIDEND HIGH, DIVIDEND LOW, DIVISOR
XDIVD1	(CALL FXGTPP)					;M-1 GETS DIVIDEND LOW, M-2 DIVISOR
	((M-A) M-1)					;SAVE DIVIDEND LOW
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		 ;GET DIVIDEND HIGH.
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 0)
    (ERROR-TABLE ARG-POPPED 0 PP M-A M-2)
	((m-1) output-selector-extend-25 c-pdl-buffer-pointer-pop)
	((M-TEM) DPB M-1
	 (BYTE-FIELD (DIFFERENCE 32. Q-POINTER-WIDTH)
		     (DIFFERENCE Q-POINTER-WIDTH 0))
	 A-A)	;LOW WORD HAS 32 BITS
	((M-A)
	 (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH 0)
		     (DIFFERENCE 32. Q-POINTER-WIDTH))
	 M-1 A-1)		;ARITH SHIFT M-1 RIGHT 8 FOR HIGH WORD
	(JUMP-GREATER-OR-EQUAL M-1 A-ZERO XDIVD3)	;MAKE DIVIDEND POSITIVE
	(JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO XDIVD2)	;DOUBLE PRECISION NEGATE M-A,,M-TEM
       ((M-TEM) SUB M-ZERO A-TEM)
	((M-A) SUB M-A (A-CONSTANT 1))			;BORROW IF LOW WORD IS ZERO
XDIVD2	((M-A) SETCM M-A)				;ONES COMPLEMENT HIGH WORD
XDIVD3	;DIVIDEND IS IN M-A (HIGH), M-TEM (LOW), DIVISOR IS IN M-2
	((M-TEM1) M-1)	;ORIGINAL SIGN OF DIVIDEND IS IN SIGN(M-TEM1) FOR DIVIDE
	((Q-R) M-TEM)					;LOW DIVIDEND TO Q-R FOR DIVIDE
#-exp(begin-comment)
	(Jump-greater-or-equal-xct-next M-2 A-Zero XDIVD3-Not-Neg-2)
       ((m-tem2) M-2)
	((M-2) SUB M-Zero A-2)
XDIVD3-Not-Neg-2
#-exp(end-comment)
	(JUMP-XCT-NEXT DIV1A)				;JOIN NORMAL DIVIDE ROUTINE
       ((M-1) DIVIDE-FIRST-STEP M-A A-2)		;BUT WITH DIFFERENT FIRST STEP

;;; ARITHMETIC MICROCODE.

;Generic operations save away one of these codes to indicate the operation to
;be performed, and then jump to routines that think about types and unpacking.
(ASSIGN ARITH-1ARG-ABS 0)
(ASSIGN ARITH-1ARG-MINUS 1)
(ASSIGN ARITH-1ARG-ZEROP 2)
(ASSIGN ARITH-1ARG-PLUSP 3)
(ASSIGN ARITH-1ARG-MINUSP 4)
(ASSIGN ARITH-1ARG-ADD1 5)
(ASSIGN ARITH-1ARG-SUB1 6)
(ASSIGN ARITH-1ARG-FIX 7)
(ASSIGN ARITH-1ARG-FLOAT 10)
(ASSIGN ARITH-1ARG-SMALL-FLOAT 11)
(ASSIGN ARITH-1ARG-HAULONG 12)
(ASSIGN ARITH-1ARG-LDB 13)	;DEALS WITH 2ND ARG ONLY.
(ASSIGN ARITH-1ARG-DPB 14)	;DEALS WITH 3RD ARG ONLY.
(ASSIGN ARITH-1ARG-ASH 15)
(ASSIGN ARITH-1ARG-ODDP 16)
(ASSIGN ARITH-1ARG-EVENP 17)
;HAIPART?
(ASSIGN NUM-UNUSED-ARITH-1ARGS 0)

;These go through the dispatches just like FIX,
;but the FIX routines do a subdispatch to decide how to round.
(ASSIGN ARITH-1ARG-FLOOR 7)
(ASSIGN ARITH-1ARG-CEIL 107)
(ASSIGN ARITH-1ARG-TRUNC 207)
(ASSIGN ARITH-1ARG-ROUND 307)
(DEF-DATA-FIELD ARITH-FIX-ROUNDING-MODE-FIELD 2 6)  ;these bits come from the destination field
		;of the INTERNAL-FLOOR-1 and INTERNAL-FLOOR-2 macroinstructions.

(ASSIGN ARITH-2ARG-ADD 0)
(ASSIGN ARITH-2ARG-SUB 1)
(ASSIGN ARITH-2ARG-MUL 2)
(ASSIGN ARITH-2ARG-IDIV 3)
(ASSIGN ARITH-2ARG-EQUAL 4)		;=
(ASSIGN ARITH-2ARG-GREATERP 5)
(ASSIGN ARITH-2ARG-LESSP 6)
(ASSIGN ARITH-2ARG-MIN 7)
(ASSIGN ARITH-2ARG-MAX 10)
(ASSIGN ARITH-2ARG-BOOLE 11)
(ASSIGN ARITH-2ARG-DIV 12)
(ASSIGN ARITH-2ARG-EQL 13)	;EQL.  Differs from = on complex numbers.
(ASSIGN NUM-UNUSED-ARITH-2ARGS 4)
;REMAINDER, EXPT?

;These codes are used to save the type of the first numeric argument in dyadic
;operations, so that the routines for handling various types of second arguments
;can dispatch on them.
(ASSIGN NUMBER-CODE-FIXNUM 0)
(ASSIGN NUMBER-CODE-SMALL-FLONUM 1)
(ASSIGN NUMBER-CODE-FLONUM 2)
(ASSIGN NUMBER-CODE-BIGNUM 3)
(ASSIGN NUM-UNUSED-NUMBER-CODES 4)

;This is the format of all DTP-HEADER words.
(DEF-DATA-FIELD HEADER-TYPE-FIELD 5 19.)
(DEF-DATA-FIELD HEADER-REST-FIELD 19. 0)
(ASSIGN-EVAL NUM-UNUSED-HEADER-TYPES (EVAL (- 32. (LENGTH Q-HEADER-TYPES))))

;This is how flonums are stored in a header, and how to convert from internal
;form (see below) back into flonum form.
(DEF-DATA-FIELD HEADER-FLONUM-EXPONENT 11. 8.)
(DEF-DATA-FIELD HEADER-FLONUM-HIGH-MANTISSA 8. 0)
(DEF-DATA-FIELD FLONUM-HEADER-HIGH-MANTISSA 8. 24.)
(DEF-DATA-FIELD FLONUM-HEADER-LOW-MANTISSA 24. 0)

;Small-flonum definitions.  These are inums, with a DTP-SMALL-FLONUM data type,
;an 8-bit excess-200 exponent (10^-38 to 10^+38 approximately), and a
;17-bit 2's complement normalized mantissa (5 digits approximately).  The
;sign bit is elided since it is always the complement of the high bit of
;the mantissa, except for zero, which is represented as an all-zero exponent
;and mantissa.

(DEF-DATA-FIELD SMALL-FLONUM-EXPONENT 8 17.)	;The exponent in a small-flonum
(ASSIGN SMALL-FLONUM-EXPONENT-OFFSET 1600)	;To convert from excess-200 to excess-2000
(ASSIGN SMALL-FLONUM-MAX-EXPONENT 377)		;Largest value that fits in exponent field
(DEF-DATA-FIELD FLONUM-SMALL-MANTISSA-FIELD 17. 14.) ;DPB here to put into low-level form
(DEF-DATA-FIELD FLONUM-SMALL-USELESS-BITS 14. 0) ;Low-order discarded bits of mantissa
(DEF-DATA-FIELD FLONUM-SMALL-ROUND-BIT 1 13.)	;Highest discarded bit
(DEF-DATA-FIELD FLONUM-SMALL-GUARD-BITS 13. 0)	;The remaining discarded bits
(DEF-DATA-FIELD FLONUM-SMALL-MANTISSA-LOW-BIT 1 14.)
(DEF-DATA-FIELD SMALL-FLONUM-MANTISSA-HIGH-BIT 1 16.)

;Both flonums and small flonums are converted to an internal
;format, on which the subrouines FADD, FSUB, FMPY, FDIV, etc. work.
;Those routines are also intended to be useful for hairier functions
;such as series expansions when written in microcode.

;These routines operate on numbers which consist of a 32-bit
;normalized 2's complement mantissa in M-1 or M-2 and an excess-2000
;exponent in M-I or M-J.  The binary point is just to the right
;of the sign (bit 31).  The range of mantissas is
;1/2 <= f < 1, -1/2 > f >= -1, except for zero which has a zero
;mantissa and a zero exponent.  All results are normalized and
;properly rounded, and returned in M-1 and M-I.  Overflow and underflow
;are not detected at this level, which is a feature.  Fuzz is not
;hacked.  Rounding is towards even if the discarded bits = exactly 1/2 lsb.

;Definitions for low-level form

(DEF-DATA-FIELD FLONUM-SIGN-BIT 1 31.)
(DEF-DATA-FIELD MANTISSA-HIGH-BIT 1 30.)
(ASSIGN FLONUM-EXPONENT-EXCESS 2000)	;The exponent is excess-2000.
(DEF-DATA-FIELD SIGN-BIT-AND-MANTISSA-HIGH-THREE 4 28.)
(DEF-DATA-FIELD SIGN-BIT-AND-MANTISSA-HIGH-TWO 3 29.)
(DEF-DATA-FIELD SIGN-BIT-AND-MANTISSA-HIGH-BIT 2 30.)

;;; Packing and unpacking fixnums.

FXUNPK-P-1
	(popj-after-next (M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	(no-op)
SIGN-EXTEND-M-1
#+lambda(POPJ-AFTER-NEXT 
		(OA-REG-HIGH) BOXED-SIGN-BIT M-1)
#+exp	((m-tem3) boxed-sign-bit m-1)
#+exp	(popj-after-next (oa-reg-high) dpb m-tem3 oah-m-src a-zero)
       ((M-1) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-1)

FXUNPK-T-2
#+lambda(POPJ-AFTER-NEXT 
		(OA-REG-HIGH) BOXED-SIGN-BIT M-T)
#+exp	((m-tem3) boxed-sign-bit m-t)
#+exp	(popj-after-next (oa-reg-high) dpb m-tem3 oah-m-src a-zero)
       ((M-2) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-T)

;;; Come to one of these to return a fixnum in M-1.
;;; Checks for fixnum overflow, and adds data type DTP-FIX.
;;; Result goes to M-T, and FIXPACK-P also pushes it on the PDL.

;;; Return the number in M-1 as either a fixnum or a bignum depending on its magnitude
;;; Returns it via M-T
RETURN-M-1
	(JUMP-LESS-THAN M-1 (A-CONSTANT NEGATIVE-SETZ) FIX-OVERFLOW-1)
	(JUMP-GREATER-OR-EQUAL M-1 (A-CONSTANT POSITIVE-SETZ) FIX-OVERFLOW-1)
	;drop into FIXPACK-T

;;; Return it via M-T checking only for single-bit overflow.  This is also open coded.
FIXPACK-T
	(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)))

;;; Return it via pdl checking only for single-bit overflow
FIXPACK-P
	(DISPATCH-POPJ-XCT-NEXT (I-ARG 1) 
	 (BYTE-FIELD 2 (DIFFERENCE Q-POINTER-WIDTH 1))
	 M-1 D-FXOVCK)
       ((C-PDL-BUFFER-POINTER-PUSH M-T) DPB M-1 Q-POINTER
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
(LOCALITY D-MEM)
;DISPATCH TABLE FOR CHECKING FOR SINGLE-BIT ADD/SUBTRACT-TYPE FIXNUM OVERFLOW
;ON VALUE WHICH IS UNBOXED IN M-1.  DISPATCH ON SIGN BIT AND LOW DATA TYPE BIT.
;I-ARG SHOULD BE 0 IF RESULT ONLY TO M-T, OR 1 IF ALSO TO PDL.  
;IN ANY CASE, DOES ESSENTIALLY POPJ-XCT-NEXT.
;NEXT SHOULD BE INSTRUCTION TO BOX M-1 AS A FIXNUM.
(START-DISPATCH 2 0)
D-FXOVCK	
	(R-BIT)					 ;BITS AGREE NO OVERFLOW
	(FIX-OVERFLOW INHIBIT-XCT-NEXT-BIT)	 ;DISAGREE => OVERFLOW
	(FIX-OVERFLOW INHIBIT-XCT-NEXT-BIT)	 ;DISAGREE => OVERFLOW
	(R-BIT)					 ;BITS AGREE NO OVERFLOW
(END-DISPATCH)

(begin-comment)	;this is part of the scheme that unfortunately doesnt work out.
;This one used after doing OUTPUT-SELECTOR-MASK-25 ADD or SUB.  Q has full result,
;M-T and C-PDL-BUFFER-POINTER have DTP-FIX and low 25 bits of result. Before the operation,
;the data types of both operands were known to be DTP-FIX. 
;  Consider add:  There are two cases, either the operands were the same sign or not.
;If the original operands were the same sign, it is possible to have a real overflow, otherwise
;not.  Note that Q.25 is a true sum bit
;(not interfered with by the data-types).  (On an ADD the tag field has been shifted 
;left one.  On a SUB it has been cancelled out).  On overflow then, Q.25 should be replicated
;in bits 31. thru 25. of M-T, and the result made into a bignum.  I-ARG should be 1
;as result is desired both on PDL and in M-T.  Note, however, that a semi-garbage result
;is ALREADY on PDL at this time.  (In case of D-FXOVCK, the INHIBIT-XCT-NEXT-BIT stops
;the semi-garbage result from getting to the PDL, but that doesnt work out here.)
;If the original operands were of opposite signs, there is no possibility of a real overflow.
;However, since we are adding 25 bit non-sign-extended quantities, our test to detect 
;overflow that boxed sign bit and the bit above it are different may go off.

(start-dispatch 2 0)
d-lambda-fast-overflow-check
	(r-bit)
	(lambda-fast-fix-overflow inhibit-xct-next-bit)
	(lambda-fast-fix-overflow inhibit-xct-next-bit)
	(r-bit)
(end-dispatch)
(end-comment)
(LOCALITY I-MEM)

;;; This is called from the fixnum packing routines. M-1 contains a unboxed number
;;; IARG is 0 if the result is to go only to M-T, and 1 if it should also go to the
;;; PDL
FIX-OVERFLOW
	(JUMP-EQUAL READ-I-ARG A-ZERO FIX-OVERFLOW-1)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
FIX-OVERFLOW-1	;Enter directly here with unboxed number in M-1.  Returns bignum in M-T.
	((M-C) M-ZERO)				;sign bit
	(JUMP-GREATER-THAN-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE)
       ((M-2) M-ZERO)
	(JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-1) SUB M-ZERO A-1)

RETURN-M-1-UNSIGNED
	(JUMP-LESS-THAN M-1 A-ZERO FIX-OVERFLOW-1-UNSIGNED)	;ANY NEGATIVE NUMBER
	(JUMP-GREATER-OR-EQUAL M-1 (A-CONSTANT POSITIVE-SETZ) FIX-OVERFLOW-1-UNSIGNED)
	(POPJ-AFTER-NEXT
         (M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)
	  
FIX-OVERFLOW-1-UNSIGNED	;Enter directly here with unboxed number in M-1.  Returns bignum in M-T.
	((M-C) M-ZERO)				;sign bit
	(JUMP-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE)
       ((M-2) M-ZERO)

(begin-comment)	;this is part of the scheme that unfortunately doesnt win.
lambda-fast-fix-overflow
	((m-2) xor m-1 a-t)		;xor signs of original operands.
	(popj-if-bit-set-xct-next boxed-sign-bit m-2)  ;return on false overflow, all ok.
       ((m-t) q-typed-pointer c-pdl-buffer-pointer)
	((MICRO-STACK-DATA-PUSH) SETA C-PDL-BUFFER-POINTER-POP  ;FLUSH SEMI-GARBAGE.
		(A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
  ;Q.25 has true sum bit, replicate it.
#+lambda((OA-REG-HIGH) BIT-ABOVE-BOXED-SIGN-BIT Q-R)		;SIGN EXTEND (MUNG M SOURCE)
#+exp	((m-tem3) bit-above-boxed-sign-bit q-r)
#+exp	((oa-reg-high) dpb m-tem3 oah-m-src a-zero)
	((M-1) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-T)
	((M-C) M-ZERO)				;sign bit
	(JUMP-GREATER-THAN-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE)
       ((M-2) M-ZERO)
	(JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-1) SUB M-ZERO A-1)
(end-comment)
	
;;; These return here before returning a value. This puts value from M-T
;;; also on stack for those that need it
M-T-TO-CPDL
	(POPJ-AFTER-NEXT
	 (C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
					 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) 
       (NO-OP)

;;; This is called from the fixnum multiply. M-2 contains the high product
;;; and M-1 the low product. Result is to go to the PDL and M-T.
FIX-2-WORD-OVERFLOW
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
FIX-2-WORD-OVERFLOW-TO-M-T
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-2 A-ZERO OVERFLOW-BIGNUM-CREATE)
       ((M-C) M-ZERO)				;sign bit
	((M-1) SUB M-ZERO A-1)
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-2) M-A-1 M-ZERO A-2)		;ONE'S COMPLEMENT
	((M-2) ADD M-2 (A-CONSTANT 1))	;CARRY FROM LOW TO HIGH WORD
					;DROPS THROUGH
;;; M-2,,M-1 HAS A 64 BIT POSITIVE NUMBER THAT IS A MAX OF 47 BITS OF PRECISION
;;; M-C GETS THE SIGN BIT
;;; M-J GETS LENGTH OF BIGNUM
OVERFLOW-BIGNUM-CREATE-NEGATIVE
	((M-C) SELECTIVE-DEPOSIT M-MINUS-ONE BIGNUM-HEADER-SIGN A-ZERO)
OVERFLOW-BIGNUM-CREATE
	;; We need a 2-word bignum if non-zero bits above the low 31. 
	(JUMP-NOT-EQUAL-XCT-NEXT M-2 A-ZERO OVERFLOW-BIGNUM-CREATE-1)
       ((M-J) (A-CONSTANT 2))
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 31.) M-1 OVERFLOW-BIGNUM-CREATE-1)
	((M-J) (A-CONSTANT 1))
OVERFLOW-BIGNUM-CREATE-1
	(CALL-XCT-NEXT BNCONS)			;Cons up a bignum
       ((M-B) ADD M-J (A-CONSTANT 1))
	((VMA) ADD M-T (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) (BYTE-FIELD 31. 0) M-1)  ;Low 31. bits
	(CHECK-PAGE-WRITE-UNBOXED)
	(POPJ-EQUAL M-J (A-CONSTANT 1))
	((M-TEM) (BYTE-FIELD 1 31.) M-1)
	((VMA) ADD VMA (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-2 (BYTE-FIELD 31. 1) A-TEM)
	(CHECK-PAGE-WRITE-UNBOXED)
	(POPJ) ;NO POPJ-AFTER-NEXT, MAY BE RETURNING TO MAIN-LOOP

;;; Packing and unpacking small flonums.

;Unpack from C-PDL-BUFFER-POINTER-POP into M-1 and M-I.
SFLUNPK-P-1
	((M-I) SMALL-FLONUM-EXPONENT C-PDL-BUFFER-POINTER)
	(POPJ-EQUAL-XCT-NEXT M-I A-ZERO FLZERO)		;zero exponent => this is 0.0
       ((M-1) DPB C-PDL-BUFFER-POINTER-POP FLONUM-SMALL-MANTISSA-FIELD A-ZERO)
	((M-I) ADD M-I (A-CONSTANT SMALL-FLONUM-EXPONENT-OFFSET))
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET MANTISSA-HIGH-BIT M-1)
       ((M-1) DPB (M-CONSTANT -1) FLONUM-SIGN-BIT A-1)  ;negative => set sign bit

;Unpack from M-T into M-2 and M-J.
SFLUNPK-T-2
	((M-J) SMALL-FLONUM-EXPONENT M-T)
	(POPJ-EQUAL-XCT-NEXT M-J A-ZERO)	;zero exponent => this is 0.0
       ((M-2) DPB M-T FLONUM-SMALL-MANTISSA-FIELD A-ZERO)
	((M-J) ADD M-J (A-CONSTANT SMALL-FLONUM-EXPONENT-OFFSET))
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET SMALL-FLONUM-MANTISSA-HIGH-BIT M-T)
       ((M-2) DPB (M-CONSTANT -1) FLONUM-SIGN-BIT A-2)

;Pack from M-1 and M-I into C-PDL-BUFFER-POINTER-PUSH and M-T, rounding.
SFLPACK-P
	(JUMP-IF-BIT-CLEAR FLONUM-SMALL-ROUND-BIT M-1 SFLPCK1)	;Jump if no rounding required
	((M-T) FLONUM-SMALL-GUARD-BITS M-1)	;Discarded fraction exactly 1/2 lsb?
	(JUMP-NOT-EQUAL M-T A-ZERO SFLPCK0)	;No, round.
	(JUMP-IF-BIT-CLEAR FLONUM-SMALL-MANTISSA-LOW-BIT M-1 SFLPCK1) ;Yes, round towards even.
SFLPCK0	(CALL-XCT-NEXT FRND1)			;Round and renormalize (may bring in two
       ((M-1) ADD M-1 (A-CONSTANT (BYTE-MASK FLONUM-SMALL-ROUND-BIT))	; garbage bits from Q)
		OUTPUT-SELECTOR-RIGHTSHIFT-1)
SFLPCK1	((M-1) DPB M-ZERO FLONUM-SMALL-USELESS-BITS A-1) ;clear low-order bits so can test zero
	(POPJ-EQUAL-XCT-NEXT M-1 A-ZERO)	;Special case 0.0, which has 0 in exponent
       ((M-T C-PDL-BUFFER-POINTER-PUSH) 	;Store mantissa and data-type fields
		FLONUM-SMALL-MANTISSA-FIELD M-1
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-SMALL-FLONUM)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
	((M-I) SUB M-I (A-CONSTANT SMALL-FLONUM-EXPONENT-OFFSET))
	(JUMP-LESS-OR-EQUAL M-I A-ZERO SFL-E-UND)	;Underflow.  ZUNDERFLOW?
	(POPJ-AFTER-NEXT
	 (M-T C-PDL-BUFFER-POINTER) DPB M-I SMALL-FLONUM-EXPONENT A-T)
       (CALL-GREATER-THAN M-I (A-CONSTANT SMALL-FLONUM-MAX-EXPONENT) SFL-E-OV) ;Overflow

SFL-E-UND
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-ZUNDERFLOW)
	(CALL-EQUAL M-TEM A-V-NIL TRAP)
	    (ERROR-TABLE FLOATING-EXPONENT-UNDERFLOW SFL)
	(POPJ-AFTER-NEXT				;Return 0.0s0 instead or if continued
	 (M-T C-PDL-BUFFER-POINTER)
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-SMALL-FLONUM)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
       (NO-OP)

SFL-E-OV (CALL TRAP)
   (ERROR-TABLE FLOATING-EXPONENT-OVERFLOW SFL)

;Pack from M-1 and M-I into M-T, rounding.
SFLPACK-T
	(CALL SFLPACK-P)
	(POPJ-AFTER-NEXT (M-GARBAGE) C-PDL-BUFFER-POINTER-POP)
       (NO-OP)

;;; Packing flonums.

;;; Note: the code to unpack flonums only exists at ARITH-FLO-ANY
;;; and ARITH-ANY-FLO, and is written there.  There is also GET-FLONUM,
;;; a general routine which is not used by the normal arithmetic path. 

;;; Take a flonum in M-1/M-I, and return a DTP-EXTENDED-NUMBER to it.
FLOPACK-T
	(CALL FLOPACK)
	(POPJ)  ;May be returning to main loop, can't popj and start-write together

FLOPACK-P
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-STACK)))
FLOPACK	(CALL-LESS-OR-EQUAL M-I A-ZERO FLOPACK-UNDERFLOW)
 	(CALL-GREATER-OR-EQUAL M-I (A-CONSTANT 4000) TRAP)
	    (ERROR-TABLE FLOATING-EXPONENT-OVERFLOW FLO)

     ;; Allocate two boxed words of structure storage in the number-cons area.
        ((m-b) seta (a-constant 2))
        (call-xct-next allocate-extended-number-storage)
       ((m-a) m-b)

	((VMA) ADD M-T (A-CONSTANT 1))		;Write the second word
	((MD-START-WRITE)
		FLONUM-HEADER-LOW-MANTISSA M-1
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (BYTE-VALUE Q-CDR-CODE CDR-NIL))))
	(CHECK-PAGE-WRITE)
	((M-TEM) FLONUM-HEADER-HIGH-MANTISSA M-1
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
				  (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-FLONUM))))
	((VMA M-T) Q-POINTER M-T
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(POPJ-AFTER-NEXT (MD-START-WRITE) DPB M-I HEADER-FLONUM-EXPONENT A-TEM)
       (CHECK-PAGE-WRITE)
	
FLOPACK-UNDERFLOW
	(POPJ-EQUAL M-1 A-ZERO)		;0.0 case: M-I has zero, don't trap
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-ZUNDERFLOW)
	(CALL-EQUAL M-TEM A-V-NIL TRAP)
	    (ERROR-TABLE FLOATING-EXPONENT-UNDERFLOW FLO)
	(POPJ-AFTER-NEXT (M-I) A-ZERO)	;Return 0.0 instead
       ((M-1) A-ZERO)

;;; Given something on stack, return a flonum unpacked into M-I and M-1, doing coercions.
;;; Clobbers only M-T, M-TEM, M-4, M-3 (inside FLOAT-A-BIGNUM)
GET-FLONUM  (ERROR-TABLE RESTART GET-FLONUM)
	(JUMP-DATA-TYPE-NOT-EQUAL C-PDL-BUFFER-POINTER
		 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)) GET-FLONUM-1)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-TEM) HEADER-TYPE-FIELD READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-FLONUM)) GET-FLONUM-2)
	((M-I) HEADER-FLONUM-EXPONENT READ-MEMORY-DATA)
	((M-1) DPB READ-MEMORY-DATA FLONUM-HEADER-HIGH-MANTISSA A-ZERO)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT NO-OP)
       ((M-1) SELECTIVE-DEPOSIT READ-MEMORY-DATA FLONUM-HEADER-LOW-MANTISSA A-1)

GET-FLONUM-1
	(JUMP-DATA-TYPE-EQUAL C-PDL-BUFFER-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-SMALL-FLONUM)) SFLUNPK-P-1)
	(JUMP-DATA-TYPE-EQUAL C-PDL-BUFFER-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CHARACTER)) GET-FLONUM-1-CHAR)
	(CALL-DATA-TYPE-NOT-EQUAL C-PDL-BUFFER-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) TRAP)
	    (ERROR-TABLE ARGTYP NUMBER PP T GET-FLONUM)
GET-FLONUM-1-CHAR
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
       ((M-I) (A-CONSTANT 2036))
	(JUMP-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)

GET-FLONUM-2
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM)) ILLOP) ;unknown type?
	((C-PDL-BUFFER-POINTER-PUSH) M-Q)
	((C-PDL-BUFFER-POINTER-PUSH) M-C)
	((C-PDL-BUFFER-POINTER-PUSH) M-K)
	((M-Q) VMA)
	((M-C) Q-POINTER READ-MEMORY-DATA)
	((M-I) BIGNUM-HEADER-LENGTH M-C)
	(CALL FLOAT-A-BIGNUM)
	((M-K) C-PDL-BUFFER-POINTER-POP)
	(POPJ-AFTER-NEXT (M-C) C-PDL-BUFFER-POINTER-POP)
       ((M-Q) C-PDL-BUFFER-POINTER-POP)

XFLOAT-FRACTION (MISC-INST-ENTRY FLOAT-FRACTION)
	(CALL GET-FLONUM)
	(JUMP-XCT-NEXT FLOPACK-T)
       ((M-I) (A-CONSTANT 2000))

XFLOAT-EXPONENT (MISC-INST-ENTRY FLOAT-EXPONENT)
	(CALL GET-FLONUM)
	((M-1) SUB M-I (A-CONSTANT 2000))
	(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)))

XSCALE-FLOAT (MISC-INST-ENTRY SCALE-FLOAT)
	(DISPATCH Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM M-T 2)
	(CALL-XCT-NEXT GET-FLONUM)
       ((M-A) Q-TYPED-POINTER PDL-POP)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-A)
	((M-I) ADD M-I A-2)
		;make result small float if arg was.
	(JUMP-DATA-TYPE-EQUAL M-A
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-SMALL-FLONUM)) SFLPACK-T)
	(JUMP FLOPACK-T)		;pack M-1/M-I

;;; Simple one-argument operations.

XABS (MISC-INST-ENTRY ABS) (ERROR-TABLE RESTART XABS)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XABS)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-ABS))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	(JUMP-GREATER-OR-EQUAL M-1 A-ZERO FIXPACK-T)
	((M-1) SUB M-ZERO A-1)
	(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)))

XMINUS (MISC-INST-ENTRY MINUS) (ERROR-TABLE RESTART XMINUS)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XMINUS)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-MINUS))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
       ((M-1) SUB M-ZERO A-1)
	(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)))

XZEROP (MISC-INST-ENTRY ZEROP) (ERROR-TABLE RESTART XZEROP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XZEROP zerop)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-ZEROP))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
FLONUM-ZEROP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-EQUAL M-1 A-ZERO)
       ((M-T) A-V-NIL)

XPLUSP (MISC-INST-ENTRY PLUSP) (ERROR-TABLE RESTART XPLUSP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XPLUSP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-PLUSP))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
FLONUM-PLUSP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-GREATER-THAN M-1 A-ZERO)
       ((M-T) A-V-NIL)

XMINUSP (MISC-INST-ENTRY MINUSP) (ERROR-TABLE RESTART XMINUSP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XMINUSP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-MINUSP))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
FLONUM-MINUSP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-LESS-THAN M-1 A-ZERO)
       ((M-T) A-V-NIL)

XODDP (MISC-INST-ENTRY ODDP) (ERROR-TABLE RESTART XODDP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XODDP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-ODDP))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET (BYTE-FIELD 1 0) M-1)
       ((M-T) A-V-NIL)

XEVENP (MISC-INST-ENTRY EVENP) (ERROR-TABLE RESTART XEVENP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XEVENP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-EVENP))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-1)
       ((M-T) A-V-NIL)

X1PLS (MISC-INST-ENTRY 1+) ;ADD1 GETS FSET TO THIS
	    (ERROR-TABLE RESTART X1PLS)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T X1PLS)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-ADD1))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-1) ADD M-1 (A-CONSTANT 1))
	(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)))

X1MNS (MISC-INST-ENTRY 1-) ;SUB1 GETS FSET TO THIS
	    (ERROR-TABLE RESTART X1MNS)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T X1MNS)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-SUB1))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-1) SUB M-1 (A-CONSTANT 1))
	(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)))

XFIX (MISC-INST-ENTRY FIX) (ERROR-TABLE RESTART XFIX)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XFIX)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-FIX))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	(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)))

XINTERNAL-FLOAT (MISC-INST-ENTRY INTERNAL-FLOAT)
XFLOAT (MISC-INST-ENTRY FLOAT) (ERROR-TABLE RESTART XFLOAT)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XFLOAT)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-FLOAT))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-I) (A-CONSTANT 2036))
	(CALL-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)
	(JUMP FLOPACK-T)

XSMALL-FLOAT (MISC-INST-ENTRY SMALL-FLOAT) (ERROR-TABLE RESTART XSMALL-FLOAT)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XSMALL-FLOAT)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-SMALL-FLOAT))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-I) (A-CONSTANT 2036))
	(CALL-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)
	(JUMP SFLPACK-T)

XHAUL (MISC-INST-ENTRY HAULONG)	;TAKES ONE ARG, RETURNS # SIGNIFICANT BITS
	    (ERROR-TABLE RESTART XHAUL)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XHAUL)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-HAULONG))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-1 A-ZERO XHAUL1)
       ((M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-1) SUB M-ZERO A-1)
XHAUL1	(POPJ-EQUAL M-1 A-ZERO)
	((M-T) ADD M-T (A-CONSTANT 1))
	(JUMP-XCT-NEXT XHAUL1)
       ((M-1) (BYTE-FIELD 31. 1) M-1)		;SHIFT RIGHT

XHAULFLO (CALL FLOPACK-P)	;HAULONG or LDB of a flonum.  Argument is unpacked.
	(CALL TRAP)		;Repack and hope don't mind if SFL became FLO in the process.
	    (ERROR-TABLE ARGTYP INTEGER PP T)

;;; Simple two-argument operations.

;;; Generic addition.
XMADD (MISC-INST-ENTRY M-+)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
XTCADD  ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POPTJ)))	;MC-LINKAGE
QIADD		(ERROR-TABLE RESTART QIADD)
	(jump-data-type-not-equal c-pdl-buffer-pointer a-t qiadd-hard)
	(jump-data-type-not-equal m-t
		(a-constant (byte-value q-data-type dtp-fix)) qiadd-hard)
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-1) ADD M-1 A-2)
	(DISPATCH-POPJ-XCT-NEXT (I-ARG 1) 	;duplicate FIXPACK-P
	 (BYTE-FIELD 2 (DIFFERENCE Q-POINTER-WIDTH 1))
	 M-1 D-FXOVCK)
       ((C-PDL-BUFFER-POINTER-PUSH M-T) DPB M-1 Q-POINTER
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))

qiadd-hard
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIADD)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-ADD))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
		(ERROR-TABLE RESTART QIADD0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QIADD0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	(JUMP-XCT-NEXT FIXPACK-P)
       ((M-1) ADD M-1 A-2)

;;; Generic subtraction.
XMSUB (MISC-INST-ENTRY M--)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
XTCSUB	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POPTJ)))	;MC-LINKAGE
QISUB		(ERROR-TABLE RESTART QISUB)
	(jump-data-type-not-equal c-pdl-buffer-pointer a-t qisub-hard)
	(jump-data-type-not-equal m-t
		 (a-constant (byte-value q-data-type dtp-fix)) qisub-hard)
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-1) SUB M-1 A-2)
	(DISPATCH-POPJ-XCT-NEXT (I-ARG 1) 	;duplicate FIXPACK-P
	 (BYTE-FIELD 2 (DIFFERENCE Q-POINTER-WIDTH 1))
	 M-1 D-FXOVCK)
       ((C-PDL-BUFFER-POINTER-PUSH M-T) DPB M-1 Q-POINTER
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
qisub-hard
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QISUB)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-SUB))
		(ERROR-TABLE RESTART QISUB0)
	((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 NUMBER M-T 1 QISUB0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-1) SUB M-1 A-2)
	(DISPATCH-POPJ-XCT-NEXT (I-ARG 1) 	;duplicate FIXPACK-P
	 (BYTE-FIELD 2 (DIFFERENCE Q-POINTER-WIDTH 1))
	 M-1 D-FXOVCK)
       ((C-PDL-BUFFER-POINTER-PUSH M-T) DPB M-1 Q-POINTER
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))

;;; Generic multiplication.
XMMUL (MISC-INST-ENTRY M-*)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
XTCMUL	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POPTJ)))	;MC-LINKAGE
QIMUL		(ERROR-TABLE RESTART QIMUL)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIMUL)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-MUL))
		(ERROR-TABLE RESTART QIMUL0)
	((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 NUMBER M-T 1 QIMUL0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)  ;CAN NOT BUM THIS BECAUSE Q LOADS DIRECTLY FROM ALU
	(CALL-XCT-NEXT MPY)	;LOW PRODUCT TO Q-R, HIGH TO M-2
       ((Q-R) M-2)
	((M-TEM) SELECTIVE-DEPOSIT Q-R
	 (BYTE-FIELD (DIFFERENCE 33. Q-POINTER-WIDTH)
		     (DIFFERENCE Q-POINTER-WIDTH 1))
	 A-2)	;DISCARDED BITS AND SIGN
	(JUMP-EQUAL-XCT-NEXT M-TEM A-ZERO FIXPACK-P)   ;JUMP IF NON-OVERFLOWING POSITIVE RESULT
       ((M-1) Q-POINTER Q-R A-TEM)		     ;SIGN EXTEND (IF NON-OVERFLOWING)
	(JUMP-EQUAL M-TEM (A-CONSTANT -1) FIXPACK-P)   ;JUMP IF NON-OVERFLOWING NEGATIVE
	(JUMP-XCT-NEXT FIX-2-WORD-OVERFLOW)
       ((M-1) Q-R)

;;; Generic division, producing integer result with integer arguments.
XMDIV (MISC-INST-ENTRY M-//)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
XTCDIV	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POPTJ)))	;MC-LINKAGE
;Division, with args on stack and in M-T, value on stack.
QIDIV		(ERROR-TABLE RESTART QIDIV)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIDIV)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-IDIV))
		(ERROR-TABLE RESTART QIDIV0)
	((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 NUMBER M-T 1 QIDIV0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	(CALL DIV)
	(JUMP-XCT-NEXT FIXPACK-P)	;DIVIDE CAN'T OVERFLOW EXCEPT FOR SETZ/-1
       ((M-1) Q-R)

;args on PDL, single result ALWAYS to PDL.  Destination field used to decode rounding mode:
; 0 -> FLOOR, 1 -> CEIL, 2 -> TRUNC, 3 -> ROUND
XFLOOR-1 (MISC-INST-ENTRY INTERNAL-FLOOR-1)
	;this must be only place it extracts destination.
	((M-1) MACRO-IR-DEST)
	(JUMP-EQUAL M-1 A-ZERO XFLOOR-1-C)
	((M-GARBAGE) MICRO-STACK-DATA-POP)	;Don't store in our destination.
XFLOOR-1-C
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
xfloor-1-uc-entry		;microcompiled code enters here.
	((M-T) Q-TYPED-POINTER PDL-POP)
				;MC-LINKAGE
;Given args on stack and M-T, return first value of FLOOR, in M-T.
;M-1 has rounding code.
XFLOOR-1-INTERNAL
	(JUMP-EQUAL M-T (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 1))
		XFLOOR-1-A)
	(DISPATCH (BYTE-FIELD 2 0) M-1 D-XFLOOR-1)
    (ERROR-TABLE ILLEGAL-INSTRUCTION)
XFLOOR-1-ROUND	;m-1 must have "rounding mode"
	((micro-stack-data-push) m-1)
	(CALL QDIV)  ;Clobbers M-INST-DEST, and all M-registers, if calls out to macrocode.
	((M-1) MICRO-STACK-DATA-POP)
;	(NO-OP)   ;QDIV returns while pushing; avoid screw from missing pass-around path.
;This code is copied from FIX, but we put the DEST field into part of M-A
;to tell the fix routine how to round.
;The DEST field should be in M-1 on arrival here.
XFLOOR-1-A
	(JUMP-DATA-TYPE-EQUAL PDL-TOP (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
		XFLOOR-1-B)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XFIX)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) DPB M-1 ARITH-FIX-ROUNDING-MODE-FIELD (A-CONSTANT ARITH-1ARG-FIX))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	(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)))

XFLOOR-1-B
	(POPJ-XCT-NEXT)
       ((M-T) Q-TYPED-POINTER PDL-POP)

;; Decide how to divide, if the second arg is not 1, based on type of rounding desired.
;; We could simply use QDIV, but in the case of two fixnum args
;; it is much faster to do some rounding in the division process itself
;; and avoid creating a rationalnum.
(LOCALITY D-MEM)
(START-DISPATCH 2 0)
D-XFLOOR-1
	(INHIBIT-XCT-NEXT-BIT XFLOOR-1-FLOOR)
	(INHIBIT-XCT-NEXT-BIT XFLOOR-1-CEIL)
	(INHIBIT-XCT-NEXT-BIT XFLOOR-1-TRUNC)
	(P-BIT R-BIT)
(END-DISPATCH)
(LOCALITY I-MEM)

;;Return nonzero in M-1 unless both M-T and PDL-TOP are fixnums.
;XFLOOR-BOTH-ARGS-FIXNUMS
;#+CADR	((M-2) Q-DATA-TYPE M-T)
;#+CADR	(POPJ-NOT-EQUAL-XCT-NEXT M-2 (A-CONSTANT (EVAL DTP-FIX)))
;#+LAMBDA(POPJ-DATA-TYPE-NOT-EQUAL-XCT-NEXT M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
;       ((M-1) A-MINUS-ONE)
;#+CADR	((M-2) Q-DATA-TYPE PDL-TOP)
;#+CADR	(POPJ-NOT-EQUAL M-2 (A-CONSTANT (EVAL DTP-FIX)))
;#+LAMBDA(POPJ-DATA-TYPE-NOT-EQUAL PDL-TOP (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
;	(POPJ-XCT-NEXT)
;	((M-1) A-ZERO)

XFLOOR-1-CEIL
 ;	(CALL XFLOOR-BOTH-ARGS-FIXNUMS)  -- loses clobbers code in M-1.
 ;	(JUMP-NOT-EQUAL M-1 A-ZERO XFLOOR-1-ROUND)
	(jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-fix))
		xfloor-1-round)
	(jump-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-fix))
		xfloor-1-round)
	;; CEIL and TRUNC are the same if the arg signs don't match.
	((M-1) XOR PDL-TOP A-T)
	(JUMP-IF-BIT-SET BOXED-SIGN-BIT M-1 XFLOOR-1-TRUNC)
;Replace the dividend with dividend+divisor-1.  (This cannot change the sign).
;(Actually, it's hairier than that.  We change dividend to dividend+divisor
;and then move back by 1 toward the original dividend.
;The amount of change is thus |divisor|-1).
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-1) ADD M-1 A-2)
	((M-1) SUB M-1 (A-CONSTANT 1))
	(JUMP-GREATER-THAN M-2 A-ZERO XFLOOR-1-CEIL-POSITIVE)
	((M-1) ADD M-1 (A-CONSTANT 2))
XFLOOR-1-CEIL-POSITIVE
	(CALL DIV)
		;DIVIDE CAN'T OVERFLOW EXCEPT FOR SETZ/-1
	((M-1) Q-R)
	(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)))

XFLOOR-1-TRUNC
	((micro-stack-data-push) m-1)
	(CALL QIDIV)
	((M-1) MICRO-STACK-DATA-POP)
	(JUMP XFLOOR-1-A)

XFLOOR-1-FLOOR
;	(CALL XFLOOR-BOTH-ARGS-FIXNUMS)
;	(JUMP-NOT-EQUAL M-1 A-ZERO XFLOOR-1-ROUND)
	(jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-fix))
		xfloor-1-round)
	(jump-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-fix))
		xfloor-1-round)
	;; FLOOR and TRUNC are the same if the arg signs match.
	((M-1) XOR PDL-TOP A-T)
	(JUMP-IF-BIT-CLEAR BOXED-SIGN-BIT M-1 XFLOOR-1-TRUNC)
;Replace the dividend with dividend-divisor+1.  (This cannot change the sign).
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	((M-1) SUB M-1 A-2)
	((M-1) ADD M-1 (A-CONSTANT 1))
	(JUMP-GREATER-THAN M-2 A-ZERO XFLOOR-1-CEIL-POSITIVE)
	((M-1) SUB M-1 (A-CONSTANT 2))
	(JUMP XFLOOR-1-CEIL-POSITIVE)		;ok not to have rounding mode in M-1
	
;Given two args on the stack, return two values on the stack.
;The destination field only says how to round (floor vs ceil vs trunc vs round).
XFLOOR-2 (MISC-INST-ENTRY INTERNAL-FLOOR-2)
		;this should be only place destination is extracted.
	((M-1) MACRO-IR-DEST)
	(JUMP-EQUAL M-1 A-ZERO XFLOOR-2-A)
	((M-GARBAGE) MICRO-STACK-DATA-POP)	;Don't store in our destination.
XFLOOR-2-A
xfloor-2-uc-entry				;microcompiled code enters here.
	((M-T) Q-TYPED-POINTER PDL-POP)
				;MC-LINKAGE
	((M-A) PDL-TOP)
	((PDL-PUSH) M-A)
	((PDL-PUSH) M-T)
	((PDL-PUSH) M-A)
	(CALL XFLOOR-1-INTERNAL)
;Stack has empty slot, dividend, divisor.
;M-T has the quotient -- the correct first value of FLOOR.
;Put it in the empty slot.
	((PDL-INDEX) SUB PDL-POINTER (A-CONSTANT 2))
	((C-PDL-BUFFER-INDEX) M-T)
;Stack has 1st value, dividend, divisor.  M-T has 1st value (quotient).
;Multiply divisor and quotient, result on stack and in M-T.
	(CALL QIMUL)
	(PDL-POP)
;Subtract product from dividend, result on stack and in M-T.
	(JUMP QISUB)

;;; Generic division, producing rational result with integer arguments.
XDIV (MISC-INST-ENTRY %DIV)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POPTJ)))	;MC-LINKAGE
;Division, with args on stack and in M-T, value on stack.
QDIV		(ERROR-TABLE RESTART QDIV)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QDIV)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-DIV))
		(ERROR-TABLE RESTART QDIV0)
	((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 NUMBER M-T 1 QDIV0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
;The args are two fixnums, now unpacked in M-1 and M-2.  Second arg packed is in M-T.
	(CALL-EQUAL M-2 A-ZERO TRAP)		;denominator of zero causes divide-by-zero trap
    (ERROR-TABLE DIVIDE-BY-ZERO)
	(JUMP-EQUAL M-1 A-ZERO QDIV-ZERO)
	(JUMP-EQUAL M-2 (A-CONSTANT 1) FIXPACK-P)
	(JUMP-GREATER-OR-EQUAL M-2 A-ZERO QDIV-SIGNS-RIGHT)
	((M-1) SUB M-ZERO A-1)
	((M-2) SUB M-ZERO A-2)
QDIV-SIGNS-RIGHT
	((M-B) M-1)
	((M-C) M-2)
;First just check to see if the result comes out even.
	(CALL DIV)
;(Remainder is in M-1, quotient in Q-R.)
	(JUMP-EQUAL-XCT-NEXT M-1 A-ZERO QDIV-EVEN)
;It doesn't, but save a step in the GCD by using this remainder instead of the first arg.
	((M-2) M-C)
	(CALL GCD-FIX-FIX)
	(JUMP-EQUAL-XCT-NEXT M-T (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 1))
		QDIV-REL-PRIME)
       ((M-1) M-C)
;Get the denominator and the GCD in M-1 and M-2.  Save the GCD in M-D.
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-D) M-2)
	(CALL DIV)
;Save denominator/gcd in M-E, and divide numerator by the gcd.
	((M-E) Q-R)
	((M-2) M-D)
	((M-1) M-B)
	(CALL DIV)
	((M-1) M-E)
;Now make a rational from numerator in Q-R and denominator in M-1.
QDIV-REL-PRIME-1
	(CALL FIXPACK-P)
	((M-1) Q-R)
	(CALL FIXPACK-P)
	(CALL MAKE-RATIONAL)
	(POPJ-AFTER-NEXT
	 (PDL-PUSH) M-T)
       (NO-OP)

QDIV-REL-PRIME
	(JUMP-XCT-NEXT QDIV-REL-PRIME-1)
       ((Q-R) M-B)

QDIV-ZERO
	(JUMP-XCT-NEXT FIXPACK-P)
       ((M-1) A-ZERO)

;Here if the division comes out even: return the quotient, as an integer.
QDIV-EVEN
	(JUMP-XCT-NEXT FIXPACK-P)	;DIVIDE CAN'T OVERFLOW EXCEPT FOR SETZ/-1
       ((M-1) Q-R)
	
XRATIO-CONS (MISC-INST-ENTRY %RATIO-CONS)
	((M-A) PDL-POP)
	((M-B) PDL-POP)
	((PDL-PUSH) M-A)
	((PDL-PUSH) M-B)

;Construct a rational from DENOMINATOR and NUMERATOR on the stack,
;and return it in M-T.  Notice that the args are not in the order you would expect!
MAKE-RATIONAL
     ;; Allocate 3 boxed words of structure storage in the number-cons area.
        ((m-b) (a-constant 3))
        (call-xct-next allocate-extended-number-storage)
       ((m-a) m-b)

	((VMA) ADD M-T (A-CONSTANT 1))		;Write the numerator.
	((MD-START-WRITE) PDL-POP)
	(CHECK-PAGE-WRITE)
	(gc-write-test)
	((WRITE-MEMORY-DATA) PDL-POP)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(gc-write-test)
;Write the header word.
	((VMA M-T) Q-POINTER M-T
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(POPJ-AFTER-NEXT
	 (MD-START-WRITE)
	 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
			   (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-RATIONAL)
			   0)))
       (CHECK-PAGE-WRITE)

;EQL is EQ, except = for numbers of matching type.
XEQL (MISC-INST-ENTRY EQL)
	((M-T) Q-TYPED-POINTER PDL-POP)
;Args in M-T and on stack.
XEQL1
	(JUMP-DATA-TYPE-NOT-EQUAL PDL-TOP A-T POP-THEN-XFALSE)
	(JUMP-DATA-TYPE-NOT-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER))
		QMEQ)
;; Both args are extended numbers.
;; Are they the same kind?
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER MD)
	((M-1) Q-TYPED-POINTER MD)
	((VMA-START-READ) PDL-TOP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER MD)
	((M-2) Q-TYPED-POINTER MD)
	(JUMP-NOT-EQUAL M-1 A-2 POP-THEN-XFALSE)
;; Yes.  Do numeric comparison.
;; Not quite the same as =, because for complex numbers
;; EQL is T only if the types of the components match.	
    (ERROR-TABLE RESTART XEQL)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 XEQL)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-EQL))
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
	(JUMP XEQL2)

;;; Generic numeric equality (the "=" function).
XMEQL (MISC-INST-ENTRY M-=)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
QMEQL					    ;MC-LINKAGE
QIEQL		(ERROR-TABLE RESTART QIEQL)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIEQL)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-EQUAL))
		(ERROR-TABLE RESTART QIEQL0)
	((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP)
XEQL2 ;; Enter from EQL, with ARITH-2ARG-EQL in M-A.
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QIEQL0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-NOT-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

;;; Generic numeric GREATERP
XMGRTH (MISC-INST-ENTRY M->)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
QMGRP					     ;MC-LINKAGE
QIGRP		(ERROR-TABLE RESTART QIGRP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIGRP)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-GREATERP))
		(ERROR-TABLE RESTART QIGRP0)
	((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 NUMBER M-T 1 QIGRP0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-LESS-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

;;; Generic numeric LESSP
XMLESS (MISC-INST-ENTRY M-<)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
QMLSP					      ;MC-LINKAGE
QILSP		(ERROR-TABLE RESTART QILSP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QILSP)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-LESSP))
		(ERROR-TABLE RESTART QILSP0)
	((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 NUMBER M-T 1 QILSP0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-GREATER-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

XMAX (MISC-INST-ENTRY *MAX)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
		(ERROR-TABLE RESTART XMAX)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 XMAX)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-MAX))
		(ERROR-TABLE RESTART XMAX0)
	((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 NUMBER M-T 1 XMAX0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	(JUMP-GREATER-OR-EQUAL M-1 A-2 FIXPACK-T)
	((M-1) A-2)
	(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)))

XMIN (MISC-INST-ENTRY *MIN)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
		(ERROR-TABLE RESTART XMIN)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 XMIN)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-MIN))
		(ERROR-TABLE RESTART XMIN0)
	((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 NUMBER M-T 1 XMIN0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)
	(JUMP-LESS-OR-EQUAL M-1 A-2 FIXPACK-T)
	((M-1) A-2)
	(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)))


;;; Data-type dispatches for arithmetic.

;;; Dispatch on the type of a one-argument numeric function.
;;; DTP-FIX unpacks and then drops through; eveything else jumps.
;;; On LAMBDA, DTP-FIX does nothing and drops thru.
(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-NUMARG
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT UNRECONCILED-ILLOP)	;UNRECONCILED
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
#+cadr	(P-BIT FXUNPK-P-1)			;FIX
#+lambda(P-BIT R-BIT)
#+exp   (P-BIT R-BIT)
	(ARITH-XNM)				;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;INDEXED-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT illop)	;unused-32
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SELF-REF-POINTER
#+cadr	(P-BIT FXUNPK-P-1)			;CHARACTER
#+lambda(P-BIT R-BIT)
#+exp	(P-BIT R-BIT)
        (p-bit n-bit illop)	;rplacd-forward
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;spare
	(ARITH-SFL)				;SMALL-FLONUM
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;;; Dispatch on the type of the first numeric arg.
;;; DTP-FIX unpacks and then drops through; eveything else jumps.
;;; On LAMBDA, DTP-FIX just drops thru.
(START-DISPATCH 5 0)
D-NUMARG1
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT UNRECONCILED-ILLOP)	;UNRECONCILED
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
#+cadr	(P-BIT FXUNPK-P-1)			;FIX
#+lambda(P-BIT R-BIT)
#+exp	(P-BIT R-BIT)
	(ARITH-XNM-ANY)				;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;INDEXED-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT illop)	;unused-32
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SELF-REF-POINTER
#+CADR	(P-BIT FXUNPK-P-1)			;CHARACTER
#+LAMBDA(P-BIT R-BIT)
#+exp	(P-BIT R-BIT)
        (p-bit n-bit illop)	;rplacd-forward
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;spare
	(ARITH-SFL-ANY)				;SMALL-FLONUM
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;;; Data type dispatch on second numeric arg, when first one was a DTP-FIXNUM.
;;; DTP-FIXNUM unpacks and drops through; everything else jumps.  First arg
;;; is unpacked into M-1.  Second arg in M-T.
;;; On LAMBDA, DTP-FIX just drops thru.
(START-DISPATCH 5 0)
D-FIXNUM-NUMARG2
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT UNRECONCILED-ILLOP)	;UNRECONCILED
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
#+CADR	(P-BIT INHIBIT-XCT-NEXT-BIT FXUNPK-T-2)	;FIX
#+LAMBDA(P-BIT R-BIT)
#+exp	(P-BIT R-BIT)
	(INHIBIT-XCT-NEXT-BIT ARITH-ANY-XNM)	;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP) 	;INDEXED-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT illop)	;unused-32
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SELF-REF-POINTER
#+CADR	(P-BIT INHIBIT-XCT-NEXT-BIT FXUNPK-T-2)	;CHARACTER
#+LAMBDA(P-BIT R-BIT)
#+exp	(P-BIT R-BIT)
        (p-bit n-bit illop)	                ;rplacd-forward
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;spare
	(INHIBIT-XCT-NEXT-BIT ARITH-FIX-SFL)	;SMALL-FLONUM
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;;; Data type dispatch for second numeric arg when first was NOT DTP-FIXNUM
;;; DTP-SMALL-FLONUM unpacks and drops through; everything else jumps.
;;; During this dispatch, the I-ARG contains a number code.
;;; The first arg has been unpacked as follows:
;;;  If BIGNUM, M-Q has BIGNUM pointer, M-C HEADER, M-I LENGTH.
;;;  If FLONUM, M-Q has FLONUM pointer, M-C HEADER, M-I exponent, M-1 mantissa.
;;;  If SMALL-FLONUM, M-Q has SMALL-FLONUM pointer, M-I has exponent, M-1 mantissa.
;;;  Also, the original pointer is kept in M-J.
(START-DISPATCH 5 0)
D-NUMARG2
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT UNRECONCILED-ILLOP)	;UNRECONCILED
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
	(ARITH-ANY-FIX)				;FIX
	(ARITH-ANY-XNM)				;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;INDEXED-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT illop)	;unused-32
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SELF-REF-POINTER
	(ARITH-ANY-FIX)				;CHARACTER
        (p-bit n-bit illop)	                ;rplacd-forward
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;spare
	(P-BIT SFLUNPK-T-2)			;SMALL-FLONUM
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; One-argument function.
ARITH-SFL
	(CALL SFLUNPK-P-1)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FLONUM-1ARG)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SFLPACK-T)))

ARITH-XNM
	((VMA-START-READ M-I) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-Q) VMA)		;get transported number address 
	(CALL-DATA-TYPE-NOT-EQUAL MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)) ILLOP)
	(DISPATCH-XCT-NEXT HEADER-TYPE-FIELD MD D-XNM-ARG)
       ((M-C) HEADER-REST-FIELD MD)

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-XNM-ARG
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-ERROR
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-ARRAY-LEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-UNUSED
	(ARITH-FLO)				;%HEADER-TYPE-FLONUM
	(ARITH-OUT)				;%HEADER-TYPE-COMPLEX
	(ARITH-BIG)				;%HEADER-TYPE-BIGNUM
	(ARITH-OUT)				;%HEADER-TYPE-RATIONAL
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-FIXED-ARGS-NO-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-VAR-ARGS-NO-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-FIXED-ARGS-WITH-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-VAR-ARGS-WITH-LOCALS
 (REPEAT NUM-UNUSED-HEADER-TYPES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

ARITH-FLO
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-I) HEADER-FLONUM-EXPONENT M-C)
	((M-1) DPB M-C FLONUM-HEADER-HIGH-MANTISSA A-ZERO)
	((M-1) SELECTIVE-DEPOSIT MD FLONUM-HEADER-LOW-MANTISSA A-1)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FLONUM-1ARG)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-T)))

;; Call out to macro-code.
ARITH-OUT
	(CALL P3ZERO)
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-NUM1))
	(DISPATCH TRANSPORT MD)
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push function
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the function code.
		Q-POINTER M-A (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
						(BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the number.
		Q-TYPED-POINTER M-I (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-JUMP MMJCALL) (I-ARG 2))		;Call tail-recursively.

;;; This dispatch SOMETIMES executes next: viz., when the result will be a number.
;;; Dispatchers can push a PACK routine in the xct-next cycle.
(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-FLONUM-1ARG
	(FLONUM-ABS)
	(FLONUM-MINUS)
	(INHIBIT-XCT-NEXT-BIT FLONUM-ZEROP)
	(INHIBIT-XCT-NEXT-BIT FLONUM-PLUSP)
	(INHIBIT-XCT-NEXT-BIT FLONUM-MINUSP)
	(FLONUM-ADD1)
	(FLONUM-SUB1)
	(INHIBIT-XCT-NEXT-BIT FLONUM-FIX)
	(INHIBIT-XCT-NEXT-BIT FLOPACK-T)
	(INHIBIT-XCT-NEXT-BIT SFLPACK-T)
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;HAULONG DOESN'T WORK FOR FLONUMS
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;LDB DOESNT EITHER.
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;NOR DPB.
	(FLONUM-ASH)				;ASH OF A FLONUM = FSC
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;ODDP ILLEGAL
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;EVENP ILLEGAL
 (REPEAT NUM-UNUSED-ARITH-1ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)


FLONUM-ABS
	(POPJ-IF-BIT-CLEAR FLONUM-SIGN-BIT M-1)
	(JUMP FNEG1)

;FLONUM-MINUS is the same as FNEG1, see below.

;FLONUM-ZEROP, FLONUM-PLUSP and FLONUM-MINUSP are up with the fixnum cases,
;see above.

FLONUM-ADD1
	((M-2) DPB M-MINUS-ONE MANTISSA-HIGH-BIT A-ZERO);10_33
	(JUMP-XCT-NEXT FADD)
       ((M-J) M+A+1 M-ZERO (A-CONSTANT 2000))		;2001

FLONUM-SUB1
	((M-2) DPB M-MINUS-ONE FLONUM-SIGN-BIT A-ZERO)	;20_33
	(JUMP-XCT-NEXT FADD)
       ((M-J) (A-CONSTANT 2000))			;2000

FLONUM-FIX
	(DISPATCH ARITH-FIX-ROUNDING-MODE-FIELD M-A D-FLONUM-FIX)

(LOCALITY D-MEM)
(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
D-FLONUM-FIX
	(FLONUM-FIX-FLOOR)
	(FLONUM-FIX-CEIL)
	(FLONUM-FIX-TRUNC)
	(FLONUM-FIX-ROUND)
(END-DISPATCH)
(LOCALITY I-MEM)

FLONUM-FIX-ROUND
	((M-TEM) SUB M-I (A-CONSTANT 2000))	;Number of bits before binary point.
	;; If expt is so big that there are no fractional bits left, just take floor.
	(JUMP-LESS-OR-EQUAL (M-CONSTANT 40) A-TEM FLONUM-FIX-FLOOR)
	;; If -.5 <= x < .5, just go return zero -- the binary point is outside the word.
	(JUMP-LESS-THAN M-TEM A-ZERO FLONUM-FIX-ZERO)
	((M-TEM) SUB (M-CONSTANT 40) A-TEM)
	((M-TEM) SUB M-TEM (A-CONSTANT 2))	;Number of bits to right of binary point, -1.
;M-TEM has position (from bottom).
	((OA-REG-LOW) oal-mrot m-TEM)
		;M-2 gets a 1 in first bit after binary point.
	((M-2) DPB (Byte-Field 1 0) M-MINUS-ONE A-ZERO)
;What follows is like FADD2, except that we clear out Q to prevent rounding up.
	((M-1) ADD M-1 A-2 OUTPUT-SELECTOR-RIGHTSHIFT-1	;Do the add, collect
		SHIFT-Q-RIGHT)	; the overflow, discarded bits to Q
	((Q-R) A-ZERO)
	(CALL FNORM)
;Now see if it's exactly an integer (that is, if it was exactly half way between before)
;Note M-I may be different now.
	((M-TEM) SUB M-I (A-CONSTANT 2000))	;Number of bits before binary point.
	(JUMP-LESS-OR-EQUAL (M-CONSTANT 40) A-TEM FLONUM-FIX-FLOOR)
	;; If -.5 <= x < .5 NOW, then the floor is certainly right.
	(JUMP-LESS-THAN M-TEM A-ZERO FLONUM-FIX-FLOOR)
	((M-TEM) SUB (M-CONSTANT 40) A-TEM)
		;Number of bits to right of binary point, -1.
	((M-TEM) SUB M-TEM (A-CONSTANT 2))
#+exp	((m-tem3) add m-tem (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-TEM #+exp m-tem3 A-ZERO OAL-BYTL-1)
       ((M-2) BYTE-INST M-1 A-ZERO)
	(JUMP-NOT-EQUAL M-2 A-ZERO FLONUM-FIX-FLOOR)
;If it is an exact integer,
;clear out the bit just before the binary point to make the result even.
;However, the integer -1.0 must be treated specially since in that case
;the only bit before the binary point is the sign bit and clearing it gives 0, not -2.0!
	(JUMP-EQUAL M-I (A-CONSTANT 2000) FLONUM-FIX-ROUND-MINUS-ONE)
#+exp	((m-tem3) add m-tem (a-constant 1))
#+exp	((oa-reg-low) oal-mrot m-tem3)
#+lambda((OA-REG-LOW) ADD M-TEM (A-CONSTANT 1))
       ((M-1) DPB (Byte-Field 1 0) M-ZERO A-1)
	(JUMP FLONUM-FIX-FLOOR)

FLONUM-FIX-CEIL-SMALL
	(JUMP-LESS-OR-EQUAL M-1 A-ZERO FLONUM-FIX-ZERO)
FLONUM-FIX-ONE
	(POPJ-AFTER-NEXT)
       ((M-T) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 1)))

FLONUM-FIX-ZERO
	(POPJ-AFTER-NEXT)
       ((M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	
;Change -1.0 into -2.0.
FLONUM-FIX-ROUND-MINUS-ONE
	((M-I) ADD M-I (A-CONSTANT 1))
	(JUMP FLONUM-FIX-FLOOR)

FLONUM-FIX-TRUNC
;TRUNC is FLOOR for positive numbers, CEIL for negative ones.
	(JUMP-IF-BIT-CLEAR FLONUM-SIGN-BIT M-1 FLONUM-FIX-FLOOR)
FLONUM-FIX-CEIL
;Add .99999999 to the number, then take the floor.
	((M-TEM) SUB M-I (A-CONSTANT 2000))	;Number of bits before binary point.
	;; If expt is so big that there are no fractional bits left, just take floor.
	(JUMP-LESS-OR-EQUAL (M-CONSTANT 40) A-TEM FLONUM-FIX-FLOOR)
	;; If -5. <= x < .5, just return 0 or 1 according to sign.
	;; The normal path would lose since the highest fractional bit doesn't exist.
	(JUMP-LESS-THAN M-TEM A-ZERO FLONUM-FIX-CEIL-SMALL)
	((M-TEM) SUB (M-CONSTANT 40) A-TEM)
		;Number of bits to right of binary point, -1.
	((M-TEM) SUB M-TEM (A-CONSTANT 2))
#+exp	((m-tem3) add m-tem (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-TEM #+exp m-tem3 OAL-BYTL-1 A-ZERO)
	((M-2) DPB M-MINUS-ONE A-ZERO)
;What follows is like FADD2, except that we clear out Q to prevent rounding up.
	((M-1) ADD M-1 A-2 OUTPUT-SELECTOR-RIGHTSHIFT-1	;Do the add, collect
		SHIFT-Q-RIGHT)	; the overflow, discarded bits to Q
	((Q-R) A-ZERO)
	(CALL FNORM)
FLONUM-FIX-FLOOR
#+lambda((oa-reg-high) flonum-sign-bit m-1)
#+exp 	((m-t) flonum-sign-bit m-1)			;M-T gets 0 if arg positive,
#+exp   ((oa-reg-high) dpb m-t oah-m-src a-zero)
       ((m-t) ldb q-pointer m-zero (a-constant (byte-value q-data-type dtp-fix)))	;return 0 or -1 if fractional
	(POPJ-LESS-OR-EQUAL M-I (A-CONSTANT 2000))
		;jump if big enough to be bignum
	(JUMP-GREATER-OR-EQUAL M-I (A-CONSTANT (PLUS 2000 Q-POINTER-WIDTH)) FLONUM-BIGFIX)
		;Byte length - 1 (maximum byte length 23.)
	((M-A) M-A-1 M-I (A-CONSTANT 2000))
	((M-B) ADD M-A (A-CONSTANT 2))		;Leftward rotation of M-1.
#+exp	((m-tem3) add m-a (a-constant 1))
	(POPJ-AFTER-NEXT (OA-REG-LOW) DPB #+lambda M-A #+exp m-tem3 OAL-BYTL-1 A-B)
       ((M-T) (BYTE-FIELD 0 0) M-1 A-T)		;A boxed signed fixnum!

FLONUM-BIGFIX
	((M-C) DPB M-T BIGNUM-HEADER-SIGN A-ZERO)	;Save sign
	(CALL FLONUM-ABS)
	((M-4) M-1)				;Save magnitude of mantissa
	((M-1) SUB M-I (A-CONSTANT (DIFFERENCE 2000 30.)))	;Compute bignum length
	(CALL-XCT-NEXT DIV)			;Q-R gets number of words,
       ((M-2) (A-CONSTANT 31.))			;M-1 gets bits minus one in last word
	((M-2) M-4)				;Restore mantissa magnitude
	((M-I) Q-R)				;Bignum length
	(CALL-XCT-NEXT BNCONS)			;Allocate a bignum result
       ((M-B) ADD Q-R (A-CONSTANT 1))
	((M-3) SUB M-I (A-CONSTANT 2))		;Zero out all but high 2 words of bignum
	(JUMP-LESS-OR-EQUAL M-3 A-ZERO FLONUM-BIGFIX1)
	((WRITE-MEMORY-DATA) M-ZERO)
FLONUM-BIGFIX0
	((VMA-START-WRITE) ADD M-T A-3)
	(CHECK-PAGE-WRITE-unboxed)
	(JUMP-GREATER-THAN-XCT-NEXT M-3 (A-CONSTANT 1) FLONUM-BIGFIX0)
       ((M-3) SUB M-3 (A-CONSTANT 1))
FLONUM-BIGFIX1
	((M-3) ADD M-1 (A-CONSTANT 2))		;Get high-order word of result
		;[Right-justify high (M-1)+1 bits of 31.]
#+exp	((m-tem3) add m-1 (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-1 #+exp m-tem3 OAL-BYTL-1 A-3)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 0 0) M-2)
	((VMA-START-WRITE) ADD M-T A-I)
	(CHECK-PAGE-WRITE-unboxed)
	(JUMP-LESS-THAN M-I (A-CONSTANT 2) BIGNUM-DPB-CLEANUP)	;No low-order word
		;Get low-order word (may be garbage)
	((M-3) M-A-1 (M-CONSTANT 32.) A-3)
	((M-1) ADD M-1 (A-CONSTANT 1))		;[Left-justify low 30.-(M-1) bits in 31.]
#+exp	((m-tem3) add m-3 (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-3 #+exp m-tem3 OAL-BYTL-1 A-1)
	((WRITE-MEMORY-DATA) DPB M-2 (BYTE-FIELD 0 0) A-ZERO)
	((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE-unboxed)
	(JUMP BIGNUM-DPB-CLEANUP)		;Might really be a fixnum after all! (SETZ)

;;; Two-argument functions.

;;; The first arg, which is on the PDL, is a SMALL-FLONUM.  ARITH-2ARG is in M-A.
ARITH-SFL-ANY		(ERROR-TABLE RESTART ARITH-SFL-ANY)
	((M-Q) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)	;Save arg in case error.
	((M-J) M-Q)			;Save arg in case of call-out.
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T D-NUMARG2 (I-ARG NUMBER-CODE-SMALL-FLONUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 ARITH-SFL-ANY)
       (CALL SFLUNPK-P-1)
	;; If it comes back here, both flonums are unpacked.
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-T 1)	;not easily continuable
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SFLPACK-P)))

;;; Second arg was a fixnum, but first wasn't.
;;; I-ARG contains type of first argument, M-A contains operation.
ARITH-ANY-FIX
	(DISPATCH-XCT-NEXT (BYTE-FIELD 3 0) READ-I-ARG D-ARITH-ANY-FIX)
       ((M-2) OUTPUT-SELECTOR-EXTEND-25 M-T)

(LOCALITY D-MEM)
(START-DISPATCH 3 0)
D-ARITH-ANY-FIX
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FIX, SHOULN'T GET HERE.
	(ARITH-SFL-FIX)				;SMALL FLONUM
	(ARITH-FLO-FIX)				;FLONUM
	(ARITH-BIG-FIX)				;BIGNUM
 (REPEAT NUM-UNUSED-NUMBER-CODES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; First arg is a fixnum unpacked.  Second arg is a small flonum, packed.
ARITH-FIX-SFL
	(CALL-XCT-NEXT SFLUNPK-T-2)
       ((M-I) (A-CONSTANT 2036))
	(CALL-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-T 1)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SFLPACK-P)))

;;; We have a small flonum in M-1,M-I and a fixnum in M-2.
;;; Reverse the order, normalize the fixnum to a flonum, and call reverse operator.
ARITH-SFL-FIX
	((M-TEM) M-2)
	((M-2) M-1)
	((M-1) M-TEM)
	((M-J) M-I)
	((Q-R) M-ZERO)
	(CALL-XCT-NEXT FNORM)
       ((M-I) (A-CONSTANT 2036))
	(DISPATCH (BYTE-FIELD 4 0) M-A D-REVERSE-FLONUM-OPS)
    (ERROR-TABLE FLONUM-NO-GOOD)	;ARGTYP not usable, arg not saved
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SFLPACK-P)))

;;; We have a flonum in M-1/M-I and a fixnum in M-2.  This is just like the above.
ARITH-FLO-FIX
	((M-TEM) M-2)
	((M-2) M-1)
	((M-1) M-TEM)
	((M-J) M-I)
	((Q-R) M-ZERO)
	(CALL-XCT-NEXT FNORM)
       ((M-I) (A-CONSTANT 2036))
	(DISPATCH (BYTE-FIELD 4 0) M-A D-REVERSE-FLONUM-OPS)
    (ERROR-TABLE FLONUM-NO-GOOD)	;ARGTYP not usable, arg not saved
    (ERROR-TABLE ARG-POPPED M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))

;;; Routines that look at the contents of M-A and act on it.

(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-FORWARD-FLONUM-OPS
	(FADD)			;ADD
	(FSUB)			;SUB
	(FMPY)			;MUL
	(FDIV)			;IDIV
	(INHIBIT-XCT-NEXT-BIT FEQL)	;=
	(INHIBIT-XCT-NEXT-BIT FGRP)	;>
	(INHIBIT-XCT-NEXT-BIT FLSP)	;<
	(FMIN)			;MIN
	(FMAX)			;MAX
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;BOOLE
	(FDIV)			;DIV
	(INHIBIT-XCT-NEXT-BIT FEQL)	;EQL
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

(START-DISPATCH 4 0)
D-REVERSE-FLONUM-OPS
	(FADD)			;REVERSE ADD
	(FSUB-REVERSE)		;REVERSE SUB
	(FMPY)			;REVERSE MPY
	(FDIV-REVERSE)		;REVERSE IDIVIDE
	(INHIBIT-XCT-NEXT-BIT FEQL)	;REVERSE =
	(INHIBIT-XCT-NEXT-BIT FLSP)	;REVERSE >
	(INHIBIT-XCT-NEXT-BIT FGRP)	;REVERSE <
	(FMIN)			;REVERSE MIN
	(FMAX)			;REVERSE MAX
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;BOOLE
	(FDIV-REVERSE)		;REVERSE DIVIDE
	(INHIBIT-XCT-NEXT-BIT FEQL)	;REVERSE EQL
(REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

FSUB-REVERSE
	(JUMP-XCT-NEXT FADD)
       (CALL FNEG1)

FDIV-REVERSE
	(JUMP-XCT-NEXT FDIV)
       (CALL SWAP-FLONUMS)

SWAP-FLONUMS
	((M-TEM) M-I)
	((M-I) M-J)
	((M-J) M-TEM)
	((M-TEM) M-1)
	(POPJ-AFTER-NEXT (M-1) M-2)
       ((M-2) M-TEM)

;;; Extended numbers.

;;; The first arg is an XNUM.  Arith op in M-A.
ARITH-XNM-ANY
	((VMA-START-READ M-J) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-Q) Q-TYPED-POINTER VMA)		;get transported number address 
	(CALL-DATA-TYPE-NOT-EQUAL MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)) ILLOP)
	(DISPATCH-XCT-NEXT HEADER-TYPE-FIELD MD D-XNM-ARG-1)
       ((M-C) HEADER-REST-FIELD MD)

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-XNM-ARG-1
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-ERROR
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-ARRAY-LEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-UNUSED
	(ARITH-FLO-ANY)				;%HEADER-TYPE-FLONUM
	(ARITH-OUT-ANY)				;%HEADER-TYPE-COMPLEX
	(ARITH-BIG-ANY)				;%HEADER-TYPE-BIGNUM
	(ARITH-OUT-ANY)				;%HEADER-TYPE-RATIONAL
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-FIXED-ARGS-NO-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-VAR-ARGS-NO-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-FIXED-ARGS-WITH-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-VAR-ARGS-WITH-LOCALS
 (REPEAT NUM-UNUSED-HEADER-TYPES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;This dispatch is used to push a return address of M-T-TO-CPDL if the
;instruction wants its result on the pdl (rather than in M-T).
;In any case we go to MMJCALL to activate the call to the macrocode routine.
(START-DISPATCH 4 0)
D-ARITH-OUT-RETURN
	(MMJCALL)		;ADD
	(MMJCALL)		;SUB
	(MMJCALL)		;MUL
	(MMJCALL)		;IDIV
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;=
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;>
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;<
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;MIN
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;MAX
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;BOOLE
	(MMJCALL)		;DIV
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;EQL
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; First argument is handled by macrocode.  Call out.
ARITH-OUT-ANY
	(CALL P3ZERO)
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-NUM2))
	(DISPATCH TRANSPORT MD)
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push function
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the function code.
		Q-POINTER M-A (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
					        (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the first number.
		Q-TYPED-POINTER M-J (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the second number.
		Q-TYPED-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(DISPATCH (BYTE-FIELD 4 0) M-A D-ARITH-OUT-RETURN (I-ARG 3))	;Call tail-recursively.
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))

;;; First arg is a real flonum.  Pointer in M-Q, header-rest in M-C, op in M-A.
ARITH-FLO-ANY
	((VMA-START-READ) M-Q ADD (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-I) HEADER-FLONUM-EXPONENT M-C)
	((M-1) DPB M-C FLONUM-HEADER-HIGH-MANTISSA A-ZERO)
    (ERROR-TABLE RESTART ARITH-FLO-ANY)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T D-NUMARG2 (I-ARG NUMBER-CODE-FLONUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 ARITH-FLO-ANY)
       ((M-1) SELECTIVE-DEPOSIT MD FLONUM-HEADER-LOW-MANTISSA A-1)
	;; If falls through, second arg is a small flonum, already unpacked.
ARITH-FLO-SFL ;This label is not used.  It is here for completeness.
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-Q 0)	;not easily continuable
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))

;;; The second arg is an extended number.  First arg is unpacked, type in I-ARG.
;;; Arith op in M-A.
ARITH-ANY-XNM
	((VMA-START-READ) M-T)
	((M-R) READ-I-ARG)			;Get number code of first arg.
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-T) VMA)		;get transported number address 
	(CALL-DATA-TYPE-NOT-EQUAL MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)) ILLOP)
	(DISPATCH-XCT-NEXT HEADER-TYPE-FIELD MD D-XNM-ARG-2)
       ((M-D) HEADER-REST-FIELD MD)

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-XNM-ARG-2
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-ERROR
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-ARRAY-LEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-UNUSED
	(ARITH-ANY-FLO)				;%HEADER-TYPE-FLONUM
	(ARITH-ANY-OUT)				;%HEADER-TYPE-COMPLEX
	(ARITH-ANY-BIG)				;%HEADER-TYPE-BIGNUM
	(ARITH-ANY-OUT)				;%HEADER-TYPE-RATIONAL
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-FIXED-ARGS-NO-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-VAR-ARGS-NO-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-FIXED-ARGS-WITH-LOCALS
        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;%HEADER-TYPE-FAST-FEF-VAR-ARGS-WITH-LOCALS
 (REPEAT NUM-UNUSED-HEADER-TYPES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; The second arg requires calling-out to macrocode.  The first
;;; argument is in M-J, unless it was a fixnum in which case
;;; it has been unpacked into M-1.  Second arg is in M-T.
ARITH-ANY-OUT
	(JUMP-NOT-EQUAL M-R (A-CONSTANT NUMBER-CODE-FIXNUM) ARITH-ANY-OUT-1)
	(CALL-XCT-NEXT FIXPACK-T)
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)
	((M-J) M-T)
	((M-T) C-PDL-BUFFER-POINTER-POP)
ARITH-ANY-OUT-1
	(CALL P3ZERO)
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-NUM2))
	(DISPATCH TRANSPORT MD)
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push function
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the function code.
		Q-POINTER M-A (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
					        (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the first number.
		Q-TYPED-POINTER M-J (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the second number.
		Q-TYPED-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(DISPATCH (BYTE-FIELD 4 0) M-A D-ARITH-OUT-RETURN (I-ARG 3))	;Call tail-recursively.
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))

;;; Number code of first arg in M-R.
;;; If is is a fixnum, small flonum, or flonum, it is unpacked in M-1/M-I.
;;; Our header rest field in M-D, our pointer in M-T.
ARITH-ANY-FLO
	((VMA-START-READ) M-T ADD (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-J) HEADER-FLONUM-EXPONENT M-D)
	((M-2) DPB M-D FLONUM-HEADER-HIGH-MANTISSA A-ZERO)
	(DISPATCH-XCT-NEXT (BYTE-FIELD 3 0) M-R D-ARITH-ANY-FLO)
       ((M-2) SELECTIVE-DEPOSIT MD FLONUM-HEADER-LOW-MANTISSA A-2)

(LOCALITY D-MEM)
(START-DISPATCH 3 0)
D-ARITH-ANY-FLO
	(ARITH-FIX-FLO)
	(ARITH-SFL-FLO)
	(ARITH-FLO-FLO)
	(ARITH-BIG-FLO)
 (REPEAT NUM-UNUSED-NUMBER-CODES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

ARITH-FIX-FLO
	((M-Q) M-1)
	((M-I) (A-CONSTANT 2036))
	(CALL-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)
	;drop in
ARITH-SFL-FLO 
ARITH-FLO-FLO
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE FLONUM-NO-GOOD)	;ARGTYP not usable, I think I lost the arg
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))

;Flonum arithmetic routines.

;These routines bash M-J, M-2, M-TEM, Q-R, A-TEMn, M-K.
;M-ZERO is an even address in M-memory.  It contains zeros, and the following
;location contains a -1.  This is used to get A-TEM1 below by hacking
;the low bit of the OA-REG-HIGH, which is the low bit of the M-source field,
;to get either a word of zeros or a word of ones depending on the sign bit
;of M-2.

;Floating Subtract.  This changes the sign of M-2 and turns into Add.
FSUB	(CALL FNEG2)
	;drop through

;Floating Add.
FADD	(JUMP-EQUAL-XCT-NEXT M-I A-J FADD2)	;Jump if exponents equal, no shifting
       ((Q-R) M-ZERO)				;Initialize discarded bits.
	(CALL-LESS-THAN-XCT-NEXT M-I A-J FADD1)	;If M-1 to shift right, exchange args
       ((M-TEM) M-A-1 M-I A-J)			;Amt to shift M-2 right minus one
	(JUMP-GREATER-OR-EQUAL M-TEM (A-CONSTANT 37) FADD3)
#+lambda((OA-REG-HIGH) FLONUM-SIGN-BIT M-2)	;Sign-extend M-2
#+exp	((m-tem3) flonum-sign-bit m-2)
#+exp	((oa-reg-high) dpb m-tem3 oah-m-src a-zero)
       ((M-TEM1) M-ZERO)			;Gets either all zeros or all ones.
	((M-J) M-A-1 (M-CONSTANT 40) A-TEM)	;40 minus exponent difference
#+exp	((m-tem3) add m-tem (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-TEM #+exp m-tem3 OAL-BYTL-1 A-J)	; becomes m-rotate
       ((M-TEM2) DPB M-2 (BYTE-FIELD 0 0) A-ZERO) ;Get bits shifted off right end of M-2
	((Q-R) A-TEM2)				;Put them in Q-R where they belong
	((M-TEM) SUB M-J (A-CONSTANT 1))	;Byte length minus one
#+exp	((m-tem3) add m-tem (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-TEM #+exp m-tem3 OAL-BYTL-1 A-J)
       ((M-2) (BYTE-FIELD 0 0) M-2 A-TEM1)	;Arithmetically shift M-2 right
FADD2	((M-1) ADD M-1 A-2 OUTPUT-SELECTOR-RIGHTSHIFT-1	;Do the add, collect
		SHIFT-Q-RIGHT)	; the overflow, discarded bits to Q
;Normalizing loop
FNORM	(DISPATCH SIGN-BIT-AND-MANTISSA-HIGH-THREE M-1 D-FNORM) ;Maybe xct-next
       ((M-I) ADD M-I (A-CONSTANT 1))		;Adjust exponent for right shift

(LOCALITY D-MEM)
(START-DISPATCH 4 0)	;s.xyz high 4 bits of sum to be normalized
D-FNORM	(INHIBIT-XCT-NEXT-BIT FNORM3)	;0.000 shift left at least 3
	(FNORM2)			;0.001 shift left 2
	(FNORM1)			;0.010 shift left 1
	(FNORM1)			;0.011 shift left 1
	(FRND)				;0.100 OK
	(FRND)				;0.101 OK
	(FRND)				;0.110 OK
	(FRND)				;0.111 OK
	(FRND)				;1.000 OK
	(FRND)				;1.001 OK
	(FRND)				;1.010 OK
	(FRND)				;1.011 OK
	(FNORM1)			;1.100 shift left 1
	(FNORM1)			;1.101 shift left 1
	(FNORM2)			;1.110 shift left 2
	(INHIBIT-XCT-NEXT-BIT FNORM3)	;1.111 shift left at least 3
(END-DISPATCH)
(LOCALITY I-MEM)

FNORM3	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((Q-R) ANDCA Q-R (A-CONSTANT 7))	;Zero the bits brought into Q
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO FNORM) ;Break the loop if trying
       ((M-I) SUB M-I (A-CONSTANT 3))		   ; to normalize zero
;Return a floating-point zero (in internal form)
FLZERO  (declare (values a-i a-1))
	(POPJ-AFTER-NEXT (M-I) A-ZERO)
       ((M-1) A-ZERO)

;If M-2 seems to pale into insignificance, it might be SETZ, which doesn't
FADD3	(POPJ-GREATER-THAN M-TEM (A-CONSTANT 37))
	(POPJ-NOT-EQUAL M-2 (A-CONSTANT (BYTE-MASK FLONUM-SIGN-BIT)))
	(JUMP-XCT-NEXT FADD2)
       ((M-2) (M-CONSTANT -1))

FNORM2	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((Q-R) ANDCA Q-R (A-CONSTANT 3))	;Zero the bits brought into Q
	(JUMP-XCT-NEXT FRND)
       ((M-I) SUB M-I (A-CONSTANT 2))

FNORM1	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((Q-R) ANDCA Q-R (A-CONSTANT 1))	;Zero the bit brought into Q
	((M-I) SUB M-I (A-CONSTANT 1))
	;drops through
;Floating-point rounding routine.
;Get here with normalized mantissa in M-1, corresponding exponent in M-I,
;residual bits in Q-R.  Rounding cannot produce zero unless given zero,
;since the input is normalized.  Do not come here with zero in M-1
;unless M-I is zero and Q-R is non-negative, or an unnormalized
;result will be returned.
;After rounding, we renormalize with a 3-bit normalize since the rounding
;can make a positive number slightly bigger and a negative number slightly smaller,
;requiring a shift of 0, 1 right, or 1 left.
FRND	(POPJ-GREATER-OR-EQUAL Q-R A-ZERO)	;Return if discarded bits < 1/2 lsb, no rounding required.
	(JUMP-NOT-EQUAL Q-R (A-CONSTANT 1_31.) FRND2)	;If discarded bits = 1/2 lsb exactly,
	(POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-1) ; then round to even
FRND2	((M-1) ADD M-1 (A-CONSTANT 1)		;Add 1 lsb to mantissa, and
		OUTPUT-SELECTOR-RIGHTSHIFT-1 SHIFT-Q-RIGHT) ; capture overflow
FRND1	(DISPATCH SIGN-BIT-AND-MANTISSA-HIGH-TWO M-1 D-FRND) ;Renormalize & popj
	((M-I) ADD M-I (A-CONSTANT 1))		;Right shift was good, fix exponent, popj

;This code is heavily bummed.  Beware.
;Note that Q normally has full low-order word.  From SFLPACK has garbage but won't be used.
FRND3	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)	;Restores the LSB from the Q.
FRND4	(POPJ-AFTER-NEXT (M-I) SUB M-I (A-CONSTANT 1))
       ((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1)	;Restores the LSB from the Q.

(LOCALITY D-MEM)
(START-DISPATCH 3 0)  ;s.xx renormalize after round
D-FRND	(INHIBIT-XCT-NEXT-BIT FRND3)	;0.00 shift left two
	(FRND4)				;0.01 shift left one
	(R-BIT)				;0.10 OK
	(R-BIT)				;0.11 OK
	(R-BIT)				;1.00 OK
	(R-BIT)				;1.01 OK
	(FRND4)				;1.10 shift left one
	(INHIBIT-XCT-NEXT-BIT FRND3)	;1.11 shift left two
(END-DISPATCH)
(LOCALITY I-MEM)

;Exchange the arguments to FADD when the second has bigger exponent
FADD1	((M-I) M-J)		;Result exponent is exp of 2nd arg
	((M-TEM) M-A-1 (M-CONSTANT -1) A-TEM)	;Repair exponent difference
	((M-4) M-2)		;Exchange mantissas
	(POPJ-AFTER-NEXT (M-2) M-1)
       ((M-1) M-4)

;Negate operand 1.  
;Normally just change the sign of the mantissa, but note that
;to retain normalization 1/2 becomes -1 and -1 becomes 1/2, with adjustment of the exponent
FLONUM-MINUS 
FNEG1	(declare (args a-i a-1) (values a-i a-1))
        (JUMP-GREATER-OR-EQUAL-XCT-NEXT M-1 A-ZERO FNEG1A)	;Jump if input positive
       ((M-1) SUB M-ZERO A-1)				;Change sign of mantissa
	(POPJ-IF-BIT-CLEAR FLONUM-SIGN-BIT M-1)		;Return if negative became positive
	(POPJ-AFTER-NEXT				;Otherwise generate 1/2 and increase
	 (M-1) DPB (M-CONSTANT -1) MANTISSA-HIGH-BIT A-ZERO) ; exponent since it must have
       ((M-I) ADD M-I (A-CONSTANT 1))			     ; been -1 which is "SETZ"
	
FNEG1A	(POPJ-NOT-EQUAL M-1 (A-CONSTANT (BYTE-MASK SIGN-BIT-AND-MANTISSA-HIGH-BIT)))
	(POPJ-AFTER-NEXT			;If result is -1/2,
	 (M-1) DPB (M-CONSTANT -1) FLONUM-SIGN-BIT A-ZERO)	;Turn it into -1
       ((M-I) SUB M-I (A-CONSTANT 1))		;and decrease exponent

;Negate operand 2.  
;Normally just change the sign of the mantissa, but note that
;to retain normalization 1/2 becomes -1 and -1 becomes 1/2, with adjustment of the exponent
FNEG2	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-2 A-ZERO FNEG2A)	;Jump if input positive
       ((M-2) SUB M-ZERO A-2)				;Change sign of mantissa
	(POPJ-IF-BIT-CLEAR FLONUM-SIGN-BIT M-2)		;Return if negative became positive
	(POPJ-AFTER-NEXT				;Otherwise generate 1/2 and increase
	 (M-2) DPB (M-CONSTANT -1) MANTISSA-HIGH-BIT A-ZERO) ; exponent since it must have
       ((M-J) ADD M-J (A-CONSTANT 1))			     ; been -1 which is "SETZ"
	
FNEG2A	(POPJ-NOT-EQUAL M-2 (A-CONSTANT (BYTE-MASK SIGN-BIT-AND-MANTISSA-HIGH-BIT)))
	(POPJ-AFTER-NEXT			;If result is -1/2,
	 (M-2) DPB (M-CONSTANT -1) FLONUM-SIGN-BIT A-ZERO)	;Turn it into -1
       ((M-J) SUB M-J (A-CONSTANT 1))		;and decrease exponent

;Floating Division.
;First, make both arguments positive, and remember if the result is to
;be negative.  Also handle arguments of zero at this stage.  Then,
;arrange for the quotient to always be normalized by dividing the
;dividend by 2 if it is greater than the divisor.  This makes the
;result mantissa be between 1/2 and 1.  Note that if the dividend and
;divisor are equal, dividing the dividend by 2 could end up producing
;an unnormalized quotient less than 1/2 because of truncation error.
;We fix this by checking specially for the case of dividend and divisor
;equal.  To get a properly-scaled quotient, we shift the dividend left
;31. bits, plus 1 more bit to get it to a word boundary.  The extra bit
;is compensated for by doing one less divide step.  After dividing, we
;do stable rounding by comparing the remainder against half the
;divisor.  Recall that divide overflow occurs if the high word of the
;dividend is greater than or equal to the divisor.
FDIV	(CALL-EQUAL M-2 A-ZERO TRAP)
		(ERROR-TABLE DIVIDE-BY-ZERO)
		(ERROR-TABLE ARG-POPPED 0 M-Q M-T)
	(POPJ-EQUAL M-1 A-ZERO)			;(// 0.0 non-0) = 0.0
	(JUMP-LESS-THAN M-2 A-ZERO FDIV3)	;Jump if divisor negative
	(JUMP-LESS-THAN M-1 A-ZERO FDIV4)	;Jump if dividend negative
FDIV1	((M-I) M-I ADD (A-CONSTANT FLONUM-EXPONENT-EXCESS))
	(JUMP-LESS-THAN-XCT-NEXT M-1 A-2 FDIV2)	;If dividend >= divisor,
       ((M-I) SUB M-I A-J)
	(JUMP-EQUAL M-1 A-2 FDIV7)
	((M-1) (BYTE-FIELD 31. 1) M-1)		;shift dividend right 1,
	((M-I) ADD M-I (A-CONSTANT 1))		;and increase exponent of result
FDIV2	((Q-R) M-ZERO)				;Low bits of dividend
	((M-1) DIVIDE-FIRST-STEP M-1 A-2)	;Do the division, doesn't call DIV due to
(REPEAT 30. ((M-1) DIVIDE-STEP M-1 A-2))	; register conflicts and orneriness
	((M-1) DIVIDE-LAST-STEP M-1 A-2)
	((M-TEM) DIVIDE-REMAINDER-CORRECTION-STEP M-1 A-2)
	;At this point, the normalized positive quotient is in Q-R, remainder is in M-TEM
	;We'd like to shift the remainder left and do an unsigned compare, but that
	;operation isn't available so we shift the divisor right and lose a bit.
	((M-TEM1) (BYTE-FIELD 31. 1) M-2)
	(POPJ-LESS-THAN-XCT-NEXT M-TEM A-TEM1)	;Round down if remainder < 1/2 divisor
       ((M-1) Q-R)
	(JUMP-GREATER-THAN M-TEM A-TEM1 FDIV6)	;Round up if remainder > 1/2 divisor
	(POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-1);Round to even lsb if remainder = 1/2 divisor
FDIV6	(JUMP-XCT-NEXT FRND1)			;Duplicate instruction at FRND2 for speed
       ((M-1) ADD M-1 (A-CONSTANT 1)		;Add 1 lsb to mantissa, and
		OUTPUT-SELECTOR-RIGHTSHIFT-1 SHIFT-Q-RIGHT) ; capture overflow

;Divisor is negative.  Change its sign and check sign of dividend
FDIV3	(JUMP-GREATER-THAN-XCT-NEXT M-1 A-ZERO FDIV5)	;Jump on positive dividend
       (CALL FNEG2)
	(JUMP-XCT-NEXT FDIV1)			;Both negative, result is positive
       (CALL FNEG1)

;Divisor is positive but dividend is negative.  Result is negative.
FDIV4	(CALL FNEG1)				;Change sign of dividend
FDIV5	(JUMP-XCT-NEXT FNEG1)			;Result is negative, get positive
       (CALL FDIV1)				; quotient and return it negated.

;Dividend and divisor mantissas equal.  Quotient mantissa is 1/2.
FDIV7	(POPJ-AFTER-NEXT (M-1) DPB (M-CONSTANT -1) MANTISSA-HIGH-BIT A-ZERO)
       ((M-I) ADD M-I (A-CONSTANT 1))

;Floating Multiplication.
FMPY	(CALL-XCT-NEXT MPY)	;Product of mantissas to M-2(high), Q-R(low)
       ((Q-R) M-2)
	(JUMP-EQUAL M-2 A-ZERO FLZERO) ;If high product of normalized operands is zero, the
				; whole product is zero.  Return proper zero.
	((M-1) M-2)		;Get result of MPY into M-1
	((M-I) M-I SUB (A-CONSTANT FLONUM-EXPONENT-EXCESS))
	(DISPATCH-XCT-NEXT SIGN-BIT-AND-MANTISSA-HIGH-TWO
			M-1 D-FMPY) ;Normalize.  May need 0, 1, or 2 left shifts
       ((M-I) M+A+1 M-I A-J)	;Exponent of product if no shifts

(LOCALITY D-MEM)
(START-DISPATCH 3 0)	;s.xy high bits of product
D-FMPY	(FNORM2)	;0.00 shift left 2
	(FNORM1)	;0.01 shift left 1
	(FRND)		;0.10 OK
	(FRND)		;0.11 OK
	(FRND)		;1.00 OK
	(FRND)		;1.01 OK
	(FNORM1)	;1.10 shift left 1
	(FNORM2)	;1.11 shift left 2
(END-DISPATCH)
(LOCALITY I-MEM)

;= for flonums.
FEQL	(POPJ-NOT-EQUAL-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-NOT-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FGRP	(JUMP-IF-BIT-SET FLONUM-SIGN-BIT M-1 FGRP-1)
	(JUMP-IF-BIT-SET FLONUM-SIGN-BIT M-2 XTRUE)
	;; Both operands to GREATERP positive
	(JUMP-GREATER-THAN M-I A-J XTRUE)
	(POPJ-LESS-THAN-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)	
	(POPJ-AFTER-NEXT POPJ-LESS-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FGRP-1	(JUMP-IF-BIT-CLEAR FLONUM-SIGN-BIT M-2 XFALSE)
	;; Both operands to GREATERP negative
	(JUMP-LESS-THAN M-I A-J XTRUE)
	(POPJ-GREATER-THAN-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)	
	(POPJ-AFTER-NEXT POPJ-LESS-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FLSP	(JUMP-IF-BIT-SET FLONUM-SIGN-BIT M-1 FLSP-1)
	(JUMP-IF-BIT-SET FLONUM-SIGN-BIT M-2 XFALSE)
	;; Both operands to LESSP positive
	(JUMP-LESS-THAN M-I A-J XTRUE)
	(POPJ-GREATER-THAN-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)	
	(POPJ-AFTER-NEXT POPJ-GREATER-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FLSP-1	(JUMP-IF-BIT-CLEAR FLONUM-SIGN-BIT M-2 XTRUE)
	;; Both operands to LESSP negative
	(JUMP-GREATER-THAN M-I A-J XTRUE)
	(POPJ-LESS-THAN-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)	
	(POPJ-AFTER-NEXT POPJ-GREATER-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FMAX	(CALL FLSP)
	(JUMP-EQUAL M-T A-V-NIL FIX-FMAX-FMIN-RETURN-ADDRESS)
	((M-1) M-2)
	((M-I) M-J)
FIX-FMAX-FMIN-RETURN-ADDRESS
	((M-TEM) MICRO-STACK-PC-DATA-POP)
	(JUMP-EQUAL M-TEM (A-CONSTANT (I-MEM-LOC SFLPACK-P)) SFLPACK-T)
	(JUMP FLOPACK-T)

FMIN	(CALL FGRP)
	(JUMP-EQUAL M-T A-V-NIL FIX-FMAX-FMIN-RETURN-ADDRESS)
	((M-1) M-2)
	(JUMP-XCT-NEXT FIX-FMAX-FMIN-RETURN-ADDRESS)
       ((M-I) M-J)

XFLOAT-DOUBLE (MISC-INST-ENTRY %FLOAT-DOUBLE)
	(CALL FXGTPP)
	((M-1) DPB M-1
	 (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH 0)
		     (DIFFERENCE 31. Q-POINTER-WIDTH))
	 A-ZERO)
	((M-1)
	 (BYTE-FIELD (DIFFERENCE 31. Q-POINTER-WIDTH)
		     (DIFFERENCE Q-POINTER-WIDTH
				 (DIFFERENCE 31. Q-POINTER-WIDTH)))
	 M-2 A-1)
	(JUMP-EQUAL M-1 A-ZERO FLOAT-DOUBLE-2)
	((M-TEM) DPB M-2
	 (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH
				 (DIFFERENCE 31. Q-POINTER-WIDTH))
		     (DIFFERENCE 32.
				 (DIFFERENCE Q-POINTER-WIDTH
					     (DIFFERENCE 31. Q-POINTER-WIDTH))))
	 A-ZERO)
	((Q-R) M-TEM)
	((M-I) (A-CONSTANT (PLUS 2000 Q-POINTER-WIDTH Q-POINTER-WIDTH -1)))
FLOAT-DOUBLE-1
	(JUMP-XCT-NEXT FLOPACK-T)
       (CALL FNORM)

FLOAT-DOUBLE-2
	((M-1) DPB M-2
	 (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH 0)
		     (DIFFERENCE 31. Q-POINTER-WIDTH))
	 A-ZERO)
	((Q-R) A-ZERO)
	(JUMP-XCT-NEXT FLOAT-DOUBLE-1)
       ((M-I) (A-CONSTANT (PLUS 2000 Q-POINTER-WIDTH -1)))

;;;  Bignum arithmetic.

(DEF-DATA-FIELD BIGNUM-HEADER-SIGN 1 18.)
(DEF-DATA-FIELD BIGNUM-HEADER-LENGTH 18. 0)

ARITH-BIG-ANY
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T D-NUMARG2 (I-ARG NUMBER-CODE-BIGNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1)	;not continuable, bignum could move
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((M-I) BIGNUM-HEADER-LENGTH M-C)
ARITH-BIG-SFL 
ARITH-BIG-FLO
	(CALL FLOAT-A-BIGNUM)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-Q 0)
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))

ARITH-ANY-BIG
	(DISPATCH-XCT-NEXT (BYTE-FIELD 3 0) M-R D-ARITH-ANY-BIG)
       ((M-J) BIGNUM-HEADER-LENGTH M-D)

(LOCALITY D-MEM)
(START-DISPATCH 3 0)
D-ARITH-ANY-BIG
	(ARITH-FIX-BIG)
	(ARITH-SFL-BIG)
	(ARITH-FLO-BIG)
	(ARITH-BIG-BIG)
 (REPEAT NUM-UNUSED-NUMBER-CODES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

ARITH-SFL-BIG 
ARITH-FLO-BIG
	((M-TEM) M-I)
	((M-I) M-J)
	((M-J) M-TEM)
	((C-PDL-BUFFER-POINTER-PUSH) M-Q)
	((M-Q) M-T)
	((M-C) M-D)
	(CALL-XCT-NEXT FLOAT-A-BIGNUM)
       ((M-2) M-1)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-REVERSE-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-T 1)
    (ERROR-TABLE ARG-POPPED 0 M-T M-Q)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))
	
ARITH-BIG
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-A D-BIGNUM-1ARG)
       ((M-I) BIGNUM-HEADER-LENGTH M-C)

(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-BIGNUM-1ARG
	(BIGNUM-ABS)
	(BIGNUM-MINUS)
	(XFALSE)		;ZEROP OF A BIGNUM!!!!!
	(BIGNUM-PLUSP)
	(BIGNUM-MINUSP)
	(BIGNUM-ADD1)
	(BIGNUM-SUB1)
	(BIGNUM-FIX)
	(BIGNUM-FLOAT)
	(BIGNUM-SMALL-FLOAT)
	(BIGNUM-HAULONG)
	(BIGNUM-LDB)
	(BIGNUM-DPB)
	(BIGASH)
	(BIGNUM-ODDP)
	(BIGNUM-EVENP)
 (REPEAT NUM-UNUSED-ARITH-1ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; Cons up a bignum.
;;; Inputs: M-B length+1, M-C sign in BIGNUM-HEADER-SIGN position
;;; Outputs: M-T boxed bignum, M-C sign/length part of header, M-E,M-K,M-S bashed
;;	     M-3, M-4, q-r also bashed.
;;;          VMA same as M-T, MD header
;;; Note that M-1 and M-2 are preserved
BNCONS ;(CALL SCONS-T)				;Cons in structure space, extra-pdl
        (call allocate-bignum-storage)
	((M-TEM) SUB M-B (A-CONSTANT 1))	;Length to go in header
	((M-C) SELECTIVE-DEPOSIT M-C BIGNUM-HEADER-SIGN A-TEM)	;Incorporate sign
	((WRITE-MEMORY-DATA) ADD M-C		;Make rest of header
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
				  (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	(POPJ-AFTER-NEXT (VMA-START-WRITE M-T)	;Store header, fix M-T data type
		Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
       (CHECK-PAGE-WRITE)

;; MD has the header of the bignum whether got here from ABS or from GCD
BIGNUM-ABS
	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN MD BIGNUM-COPY)
       ((M-C) M-I)				;Positive-signed header
RETURN-M-Q
 	(POPJ-AFTER-NEXT (M-T) M-Q)
       (NO-OP)

BIGNUM-MINUS
	(JUMP-NOT-EQUAL M-C (A-CONSTANT (BYTE-VALUE BIGNUM-HEADER-LENGTH 1))
			BIGNUM-MINUS-1)	;check for +setzness
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD (A-CONSTANT POSITIVE-SETZ) BIGNUM-MINUS-1)
	(POPJ-AFTER-NEXT (M-T) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
						 POSITIVE-SETZ)))
       (NO-OP)
BIGNUM-MINUS-1
	((M-C) XOR M-C (A-CONSTANT (BYTE-MASK BIGNUM-HEADER-SIGN)))
;bignum in M-Q, new header(sign) in M-C, Length in M-I. Result in M-T.
BIGNUM-COPY
	(CALL-XCT-NEXT BNCONS)			;ALLOCATE IN STRUCTURE EXTRA-PDL
       ((M-B) ADD M-I (A-CONSTANT 1))
BIGNUM-COPY-L
	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((VMA-START-WRITE) ADD M-T A-I)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-GREATER-THAN-XCT-NEXT M-I (A-CONSTANT 1) BIGNUM-COPY-L)
       ((M-I) SUB M-I (A-CONSTANT 1))
	(POPJ)

DPB-BIGNUM-SETUP  ;CALL HERE TO SET UP FOR DOING A DPB, SEE RELEVANT CODE.
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)
	((M-E) (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 6)) 6) C-PDL-BUFFER-POINTER)
	((M-1) ADD M-K A-E)			;COMPUTE BIT POSITION OF LEFT EDGE OF BYTE
	((M-1) ADD M-1 (A-CONSTANT 31.))	;ROUND UP
		;Note the inclusion of one extra bit.  This is in case we produce
		;a negative "SETZ", which is 1 bit longer in sign-and-magnitude than
		;in 2's complement.
	(CALL-XCT-NEXT DIV)	;DIVIDE BY 31. TO GET NUMBER OF WORDS IN BIGNUM
       ((M-2) (A-CONSTANT 31.))	;RETURN QUOTIENT IN Q-R
	((M-B) Q-R)		;NEED AT LEAST THIS MANY WORDS.
BIGNUM-COPY-EXPAND   ;Copy bignum.  Resulting bignum to have at least M-B words of
		     ;significance.  Start with bignum in M-Q, header in M-C, current
		     ;length in M-I.  Result in M-T.  As a special hack, if M-I is zero,
		     ;just allocate a 0 bignum.
	(JUMP-GREATER-OR-EQUAL M-I A-B BIGNUM-COPY)     ;No expansion needed, just copy
	(CALL-XCT-NEXT BNCONS)				;Allocate in structure extra-pdl
       ((M-B) ADD M-B (A-CONSTANT 1))    		;Plus one for header
	((M-B) SUB M-B (A-CONSTANT 1))
	(CALL-NOT-EQUAL-XCT-NEXT M-I A-ZERO BIGNUM-COPY-L)	;Copy the number part (if any)
       ((M-ZR) SUB M-B A-I)		;Save how many words to zero
	((MD) A-ZERO)
BCE2	((VMA-START-WRITE) ADD M-T A-B)	;Zero out the new words.
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-ZR) SUB M-ZR (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-ZR A-ZERO BCE2)
       ((M-B) SUB M-B (A-CONSTANT 1))
	(POPJ)

BIGNUM-PLUSP
	((M-T) A-V-TRUE)		;CORRECT SINCE NO BIGNUM ZERO
	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR BIGNUM-HEADER-SIGN M-C)
       ((M-T) A-V-NIL)

BIGNUM-MINUSP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
       ((M-T) A-V-NIL)

BIGNUM-FIX
	(POPJ-AFTER-NEXT (M-T) M-Q)
       (NO-OP)

BIGNUM-HAULONG
	((VMA-START-READ) ADD M-Q A-I)	;GET HIGH ORDER WORD
	(CHECK-PAGE-READ)
	;; (length - 1) * 31. =  (length * 32.) - length - 31.
	;; XHAUL1 wants this in M-T  and the high bits in M-1.
	((M-T) DPB M-I (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 5)) 5.)
	 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-T) SUB M-T A-I)
	((M-T) SUB M-T (A-CONSTANT 31.))
	(JUMP-XCT-NEXT XHAUL1)
       ((M-1) MD)

BIGNUM-FLOAT
	(JUMP-XCT-NEXT FLOPACK-T)
       (CALL FLOAT-A-BIGNUM)

BIGNUM-SMALL-FLOAT
	(JUMP-XCT-NEXT SFLPACK-T)
       (CALL FLOAT-A-BIGNUM)

BIGNUM-ODDP
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))	;Low-order word
	(CHECK-PAGE-READ)
	(JUMP-XCT-NEXT XFALSE)
       (JUMP-IF-BIT-SET (BYTE-FIELD 1 0) READ-MEMORY-DATA XTRUE)

BIGNUM-EVENP
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))	;Low-order word
	(CHECK-PAGE-READ)
	(JUMP-XCT-NEXT XFALSE)
       (JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) READ-MEMORY-DATA XTRUE)

;;; Convert a bignum to a flonum.  Takes the length of the bignum in M-I,
;;; the bignum pointer in M-Q, the rest-of-header in M-C.  Leaves an internal-format
;;; flonum in M-I and M-1.  Clobbers M-4, M-3, M-1, M-K, M-TEM, M-T.  Must NOT clobber
;;; M-A, M-2 and M-J!
FLOAT-A-BIGNUM
	;; First get the second-to-highest order word into M-3.
	;; (If there is only one word, get zeroes.)
	(JUMP-EQUAL-XCT-NEXT M-I (A-CONSTANT 1) FLOAT-A-BIGNUM-X)
       ((M-3) A-ZERO)
	((M-TEM) SUB M-I (A-CONSTANT 1))
	((VMA-START-READ) ADD M-Q A-TEM)
	(CHECK-PAGE-READ)
	((M-3) MD)
FLOAT-A-BIGNUM-X
	;; Now get the highest order word in M-1 and get its length in M-T.
	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((M-T) A-ZERO)
	(CALL-XCT-NEXT XHAUL1)
       ((M-1 C-PDL-BUFFER-POINTER-PUSH) MD) ;EVIL ON PDL BUFFER, BUT WILL BE POPPED SOON
	;; If M-T contains 31. then the mantissa is on the pdl
	;; no need to ldb/dpb anything (in fact it won't work!)
	(JUMP-EQUAL M-T (A-CONSTANT 31.) FLOAT-A-BIGNUM-31)
	;; Now piece together the mantissa of the flonum into M-1.
	;; First LDB from M-3, with:
	;;		BYTL-1 = (30. - M-T)	MROT = (32. - M-T)
	;; Then DPB from C-PDL-BUFFER-POINTER-POP into M-1, with:
	;;		BYTL-1 = (M-T - 1)	MROT = (31. - M-T)
	((M-TEM) SUB (M-CONSTANT 32.) A-T)
	((M-4) SUB M-TEM (A-CONSTANT 2))
#+exp	((m-tem3) add m-4 (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-4 #+exp m-tem3 OAL-BYTL-1 A-TEM)
	((M-1) (BYTE-FIELD 0 0) M-3 A-ZERO)
	((OA-REG-LOW) #+exp oal-mrot M-TEM)	;Rotate first dropped bit into sign of M-3
	((M-3) (BYTE-FIELD 32. 0) M-3)
	((M-K) SUB M-T (A-CONSTANT 1))
	((M-TEM) ADD M-4 (A-CONSTANT 1))
#+exp	((m-tem3) add m-k (a-constant 1))
	((OA-REG-LOW) DPB #+lambda M-K #+exp m-tem3 OAL-BYTL-1 A-TEM)
	((M-1) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 0 0) A-1)
FLOAT-A-BIGNUM-DONE
	;; length in M-I   nbits (sig bits in high order word) in M-T
	;; (length - 1) * 31. + nbits + 2000 =  
	;;       (length * 32. + nbits) - length + 1741
	((M-T) DPB M-I (BYTE-FIELD 27. 5.) A-T) ;Clears data-type
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 31.) M-3 FLOAT-A-BIGNUM-EXIT)
       ((M-T) SUB M-T A-I)
	((M-1) ADD M-1 (A-CONSTANT 1))		;First dropped bit was a 1, round up
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 31.) M-1 FLOAT-A-BIGNUM-EXIT)
	((M-1) (BYTE-FIELD 31. 1) M-1)		;Overflowed, shift right and
	((M-T) ADD M-T (A-CONSTANT 1))		; increase exponent
FLOAT-A-BIGNUM-EXIT
	(POPJ-AFTER-NEXT (M-I) ADD M-T (A-CONSTANT 1741))
       (CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C FNEG1)

FLOAT-A-BIGNUM-31
	(JUMP-XCT-NEXT FLOAT-A-BIGNUM-DONE)
       ((M-1) C-PDL-BUFFER-POINTER-POP)


ARITH-BIG-BIG
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-A D-FORWARD-BIGNUM-OPS)
       ((M-B) M-T)

(LOCALITY D-MEM)
;BIGNUMS IN M-B AND M-T, M-Q.  THEIR HEADERS IN M-D, M-C.  LENGTHS IN M-J, M-I.
(START-DISPATCH 4 0)
D-FORWARD-BIGNUM-OPS
	(BADD)
	(BSUB)
	(BMPY)
	(BIDIV)
	(BEQL)
	(BGRP)
	(BLSP)
	(BMIN)
	(BMAX)
	(BBOOLE)
	(BDIV)
	(BEQL)
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

BEQL	(POPJ-NOT-EQUAL-XCT-NEXT M-C A-D)
       ((M-T) A-V-NIL)
BEQL1	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((M-1) MD)
	((VMA-START-READ) ADD M-B A-I)
	(CHECK-PAGE-READ)
	(POPJ-NOT-EQUAL MD A-1)
	(JUMP-GREATER-THAN-XCT-NEXT M-I (A-CONSTANT 1) BEQL1)
       ((M-I) SUB M-I (A-CONSTANT 1))
	(POPJ-AFTER-NEXT (M-T) A-V-TRUE)
       (NO-OP)

;; this loops over two bignum's magnitudes (in M-Q,M-C,M-I and M-B,M-D,M-J) does nothing
;; if the first is larger than the second, puts M-E in M-T if they are equal
;; else moves M-A into M-T.  In any case POPJing out. Smashes M-I (which better equal M-J
;; anyway!!!!)

BSHFFL	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((M-1) MD)
	((VMA-START-READ) ADD M-B A-I)
	(CHECK-PAGE-READ)
	(POPJ-LESS-THAN MD A-1)			;first is bigger so popj
	(JUMP-NOT-EQUAL MD A-1 BSHFFL-1)	;second is bigger, move and popj
	;equal continue looping
	(JUMP-GREATER-THAN-XCT-NEXT M-I (A-CONSTANT 1) BSHFFL)
       ((M-I) SUB M-I (A-CONSTANT 1))
	(POPJ-AFTER-NEXT (M-T) M-E)		;all equal return M-E
       (NO-OP)

BSHFFL-1
	(POPJ-AFTER-NEXT NO-OP)
       ((M-T) M-A)

;; compare two bignums (in M-Q,M-C,M-I and M-B,M-D,M-J) and return T if first
;; is bigger than the second. Uses M-A and M-T and M-E
BGRP	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-C BGRP-1)
       ((M-E) A-V-NIL)				;Value to return if equal
	(POPJ-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) A-V-TRUE)				;First is pos., second is neg.
	(POPJ-GREATER-THAN M-I A-J)		;Both pos. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;Both pos. Same length so loop.
       ((M-A) A-V-NIL)				;M-A gets alternate answer
	(POPJ-AFTER-NEXT (M-T) A-V-NIL)		;Both pos. Second longer.
       (NO-OP)

BGRP-1	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) A-V-NIL)				;First is neg. second is pos.
	(POPJ-GREATER-THAN M-I A-J)		;both neg. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;both neg. same length so loop.
       ((M-A) A-V-TRUE)				;M-A gets other answer
	(POPJ-AFTER-NEXT (M-T) A-V-TRUE)	;both neg. second longer.
       (NO-OP)

;; compare two bignums (in M-Q,M-C,M-I and M-B,M-D,M-J) and return T if second
;; is bigger than the first. Uses M-A and M-T and M-E
BLSP	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-C BLSP-1)
       ((M-E) A-V-NIL)				;Value to return if equal
	(POPJ-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) A-V-NIL)				;First is pos., second is neg.
	(POPJ-GREATER-THAN M-I A-J)		;Both pos. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;Both pos. Same length so loop.
       ((M-A) A-V-TRUE)				;M-A gets alternate answer
	(POPJ-AFTER-NEXT (M-T) A-V-TRUE)	;Both pos. Second longer.
       (NO-OP)

BLSP-1	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) A-V-TRUE)				;First is neg. second is pos.
	(POPJ-GREATER-THAN M-I A-J)		;both neg. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;both neg. same length so loop.
       ((M-A) A-V-NIL)				;M-A gets other answer
	(POPJ-AFTER-NEXT (M-T) A-V-NIL)		;both neg. second longer.
       (NO-OP)

;; compare two bignums (in M-Q,M-C,M-I and M-B,M-D,M-J) and return the bigger one.
;; Uses M-A and M-T and M-E
BMAX	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-C BMAX-1)
       ((M-E) M-Q)				;Value to return if equal
	(POPJ-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) M-Q)				;First is pos., second is neg.
	(POPJ-GREATER-THAN M-I A-J)		;Both pos. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;Both pos. Same length so loop.
       ((M-A) M-B)				;M-A gets alternate answer
	(POPJ-AFTER-NEXT (M-T) M-B)		;Both pos. Second longer.
       (NO-OP)

BMAX-1	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) M-B)				;First is neg. second is pos.
	(POPJ-GREATER-THAN M-I A-J)		;both neg. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;both neg. same length so loop.
       ((M-A) M-Q)				;M-A gets other answer
	(POPJ-AFTER-NEXT (M-T) M-Q)		;both neg. second longer.
       (NO-OP)

;; compare two bignums (in M-Q,M-C,M-I and M-B,M-D,M-J) and return the smaller one.
;; Uses M-A and M-T and M-E
BMIN	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-C BMIN-1)
       ((M-E) M-Q)				;Value to return if equal
	(POPJ-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) M-B)				;First is pos., second is neg.
	(POPJ-GREATER-THAN M-I A-J)		;Both pos. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;Both pos. Same length so loop.
       ((M-A) M-Q)				;M-A gets alternate answer
	(POPJ-AFTER-NEXT (M-T) M-Q)		;Both pos. Second longer.
       (NO-OP)

BMIN-1	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) M-Q)				;First is neg. second is pos.
	(POPJ-GREATER-THAN M-I A-J)		;both neg. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;both neg. same length so loop.
       ((M-A) M-B)				;M-A gets other answer
	(POPJ-AFTER-NEXT (M-T) M-B)		;both neg. second longer.
       (NO-OP)

;; For add and subtract build the answer in M-T,M-K . sign of answer is expected to
;; be the sign bit in M-C. First arg in M-Q,M-I second in M-R,M-J (note the move to M-R)

;; For addition we want the longest BIGNUM in M-R,M-J

BADD	((M-TEM) XOR M-C A-D)
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-TEM BSUB1) ;signs don't agree so subtract
BADD1	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-J A-I BADD2)
       ((M-2) A-ZERO)				;M-2 gets the carry
	((M-TEM) M-I)				;Swap if second isn't largest.
	((M-I) M-J)
	((M-J) M-TEM)
	((M-B) M-Q)				;M-T and M-B contain the same thing!
	((M-Q) M-T)
BADD2	((M-R) M-B)
	(CALL-XCT-NEXT BNCONS)			;Allocate result bignum
       ((M-B) ADD M-J (A-CONSTANT 2))
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
					 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((M-D) (A-CONSTANT 1))			;M-D counts up
BADD3	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((M-1) ADD MD A-2)			;M-2 has carry from last round
	((VMA-START-READ) ADD M-R A-D)
	(CHECK-PAGE-READ)
	((M-1) ADD MD A-1)			;M-1 now has sum (carry and 31 bits out)
	((MD) (BYTE-FIELD 31. 0) M-1 A-ZERO)	;Write 31 bits
	((M-2) (BYTE-FIELD 1 31.) M-1 A-ZERO)	;save carry
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-LESS-THAN-XCT-NEXT M-D A-I BADD3)
       ((M-D) ADD M-D (A-CONSTANT 1))
	(JUMP-GREATER-THAN M-D A-J BADD4)	;Jump if lengths (M-I,M-J) were equal,
						; there are no more words to add in
;;FIXNUM - BIGNUM addition joins us here (can drop in)
;; Bignum in M-R,M-J. 1 (sometimes) in M-D. Fixnum in M-2. Answer in M-T with header in M-C.
BADD5	((VMA-START-READ) ADD M-R A-D)
	(CHECK-PAGE-READ)
	((M-1) ADD MD A-2)			;M-2 has carry
	((MD) (BYTE-FIELD 31. 0) M-1 A-ZERO)
	((M-2) (BYTE-FIELD 1 31.) M-1 A-ZERO)
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-LESS-THAN-XCT-NEXT M-D A-J BADD5)	;M-J'th word is last in M-R bignum
       ((M-D) ADD M-D (A-CONSTANT 1))
BADD4	(JUMP-GREATER-THAN M-2 A-ZERO BADD6)	;There was some carry, so store in last word.
	((M-C) SUB M-C (A-CONSTANT 1))		;no carry so give word back.
	((MD) ADD M-C (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-1) ADD M-T A-D)
	(JUMP-XCT-NEXT UN-CONS)
       ((M-2) (A-CONSTANT 1))

BADD6	((MD) M-2)
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE-UNBOXED)
	(POPJ)		;NO POPJ-AFTER-NEXT, COULD BE RETURNING TO MAIN LOOP

;; Subtraction:
BSUB	((M-TEM) XOR M-C A-D)
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-TEM BADD1)	;signs don't agree so add
;; first we shuffle the bignums around to be sure of subtracting the smaller magnitude
;; from the larger. Note that if we switch them then we must complement the sign bit in M-C.
BSUB1	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
	((M-R) M-T)				;will need M-T for answer
	(JUMP-GREATER-THAN-XCT-NEXT M-I A-J BSUB-OK)
       ((M-D) M-I)				;M-D gets the number of the last different word
	(JUMP-LESS-THAN M-I A-J BSUB-SWITCH)
	;drops in
;; they are the same length so count M-D down until you find a word that is different.
;; M-J is also kept equal to M-D since there is no need to remember the words out there
;; if when you subtract them you get zero.  (7623456123-7623456032 is the same as 123-032 !)
BSUB-L	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((M-J) M-D)
	((M-1) MD)
	((VMA-START-READ) ADD M-R A-D)
	(CHECK-PAGE-READ)
	(JUMP-LESS-THAN MD A-1 BSUB-OK)
	(JUMP-GREATER-THAN MD A-1 BSUB-SWITCH-1)
	(JUMP-GREATER-THAN-XCT-NEXT M-D (A-CONSTANT 1) BSUB-L)
       ((M-D) SUB M-D (A-CONSTANT 1))
	(POPJ-AFTER-NEXT
	 (M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;EQUAL!
       (NO-OP)

BSUB-SWITCH
	((M-TEM) M-I)				;Switch (but nobody cares about M-I)
	((M-D) M-J)
	((M-J) M-TEM)
BSUB-SWITCH-1
	((M-C) XOR M-C (A-CONSTANT (BYTE-MASK BIGNUM-HEADER-SIGN)))	;Switch sign bit.
	((M-R) M-Q)
	((M-Q) M-T)				;M-T still contains the original thing!

;; we have now cleverly arranged for M-D to be the length of the longest possible answer
;; M-Q,(M-I *) contain the bigger magnitude bignum M-R,M-J the smaller
;; correct sign bit of answer is in M-C, answer to be built in M-T,M-C (sign bit kept
;; in M-C)
;; (* note that we really don't care about M-I so we havn't actually made sure it contains
;; the correct thing)
BSUB-OK	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-D (A-CONSTANT 1))
	((M-2) A-ZERO)				;borrow
	((M-B) (A-CONSTANT 1))			;counter
BSUB-IT	((VMA-START-READ) ADD M-R A-B)
	(CHECK-PAGE-READ)
	((M-1) ADD MD A-2)
	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-1) SUB MD A-1)
	((MD M-3) (BYTE-FIELD 31. 0) M-1 A-ZERO)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-EQUAL-XCT-NEXT M-3 A-ZERO BSUB-IT1)
       ((M-2) (BYTE-FIELD 1 31.) M-1 A-ZERO)
	((M-E) M-B)				;M-E gets number of last non-zero word stored
BSUB-IT1
	(JUMP-LESS-THAN-XCT-NEXT M-B A-J BSUB-IT)
       ((M-B) ADD M-B (A-CONSTANT 1))
	(JUMP-GREATER-THAN M-B A-D BCLEANUP)	;Jump if no more words to borrow into
;;FIXNUM - BIGNUM subtraction joins us here.
;; Bignum in M-Q,M-D (yes M-D!). 1 in M-B. Fixnum in M-2. Answer in M-T with header in M-C.
;; 1 should be in M-E (despite the fact that that might be wrong, the answer will be
;; spotted as a fixnum zero anyway!)
BSUB-C	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-1) SUB MD A-2)
	((MD M-3) (BYTE-FIELD 31. 0) M-1 A-ZERO)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-EQUAL-XCT-NEXT M-3 A-ZERO BSUB-C1)
       ((M-2) (BYTE-FIELD 1 31.) M-1 A-ZERO)
	((M-E) M-B)				;Index of last non-zero word
BSUB-C1 (JUMP-LESS-THAN-XCT-NEXT M-B A-D BSUB-C)
       ((M-B) ADD M-B (A-CONSTANT 1))
	(JUMP BCLEANUP)

;; multiply two bignums.
BMPY	((M-R) M-T)
	((M-K) ADD M-I A-J)	;Possible length of answer
	((M-C) XOR M-C A-D)	;Sign in C is correct
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-K (A-CONSTANT 1))
	((M-K) BIGNUM-HEADER-LENGTH M-C)		;M-K was smashed by SCONS
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
					 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))

;; Now we have first arg in M-Q,M-I  second in M-R,M-J .  We are building the answer in
;; M-T,M-K .  The correct header for the answer lives in M-C.
;; M-S will index into the answer, M-D into first arg, M-E + 1 into second.
;; it must be true that M-D + M-E = M-S
;; the running total is kept in M-A,M-2,M-1
;; M-B gets M-J - 1 for comparison
;; M-ZR gets M-K - 1 for comparison
	((M-B) SUB M-J (A-CONSTANT 1))
	((M-ZR) SUB M-K (A-CONSTANT 1))
	((M-S) (A-CONSTANT 1))
	((M-A) A-ZERO)
	((M-1) A-ZERO)
	((M-2) A-ZERO)
BMPY-LOOP
	(JUMP-GREATER-THAN-XCT-NEXT M-S A-I BMPY-LOOP-1)
       ((M-D) M-I)
	((M-D) M-S)		;M-D gets min{M-I,M-S}
BMPY-LOOP-1
	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((M-E) SUB M-S A-D)
	((M-3) MD)
	((VMA-START-READ) M+A+1 M-R A-E)
	(CHECK-PAGE-READ)
	((Q-R) MD)
	;; Having loaded the 2 31 bit things to be multiplied into Q-R and M-3
	;; this will multiply them and add the result into M-A,M-2,M-1
	;; (31 bits in M-1 and M-2, less than 24 in M-A)
(REPEAT 31. ((M-1) MULTIPLY-STEP M-1 A-3))
	((M-1) ADD M-1 A-2)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 31.) M-1 BMPY-C)
       ((M-2) (BYTE-FIELD 31. 0) M-1 A-ZERO)
	((M-A) ADD M-A (A-CONSTANT 1))
BMPY-C	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-E A-B BMPY-LOOP-1-DONE)	;M-B = M-J - 1
       ((M-1) (BYTE-FIELD 31. 1) Q-R A-ZERO)
	(JUMP-GREATER-THAN-XCT-NEXT M-D (A-CONSTANT 1) BMPY-LOOP-1)
       ((M-D) SUB M-D (A-CONSTANT 1))
BMPY-LOOP-1-DONE
	((MD) M-1)
	((VMA-START-WRITE) ADD M-T A-S)
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-1) M-2)
	((M-2) M-A)
	((M-A) A-ZERO)
	(JUMP-LESS-THAN-XCT-NEXT M-S A-ZR BMPY-LOOP)	;M-ZR = M-K - 1
       ((M-S) ADD M-S (A-CONSTANT 1))
	(JUMP-NOT-EQUAL M-1 A-ZERO BMPY-FULL)
	((M-C) SUB M-C (A-CONSTANT 1))		;Result 1 word shorter than expected
	((MD) ADD M-C (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-1) ADD M-T A-K)
	(JUMP-XCT-NEXT UN-CONS)
       ((M-2) (A-CONSTANT 1))

BMPY-FULL
	((MD) M-1)
	((VMA-START-WRITE) ADD M-T A-S)
	(CHECK-PAGE-WRITE-UNBOXED)
	(POPJ)		;NO POPJ-AFTER-NEXT, MIGHT BE RETURNING TO MAIN LOOP

;;; Bignum - Bignum division: (algorithm from Knuth Vol 2)
BIDIV
	;;If second bignum is longer than the first bignum then the answer is 0
	(JUMP-GREATER-THAN M-J A-I RETURN-ZERO)
	;;Get sign of answer into M-C by xoring with M-D
	((M-D) SELECTIVE-DEPOSIT BIGNUM-HEADER-SIGN M-D A-ZERO)
	((M-C) XOR M-C A-D)
	;;If second is one word long then we can do Bignum - Fixnum division
	(JUMP-GREATER-THAN-XCT-NEXT M-J (A-CONSTANT 1) BIDIV-1)
       ((M-R) M-T)
	((VMA-START-READ) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(JUMP-XCT-NEXT BFXIDIV)
       ((M-2) MD)

BIDIV-1
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
	;;Allocate a bignum for the answer: (put it in M-A)
	((M-A) SUB M-I A-J)
	((M-A) ADD M-A (A-CONSTANT 1))	;Possible length of answer.
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-A (A-CONSTANT 1))
	(CALL-XCT-NEXT BIDIV-REMAINDER-COMMON)
       ((M-A) M-T)
	;;M-Q,(M-I + 1) contains garbage. M-T,M-K contains the answer (with perhaps
	;; a zero in the top word). M-C has the correct sign bit for the answer.
	((M-1) M-Q)
	((M-2) ADD M-I (A-CONSTANT 2))
	(CALL-XCT-NEXT UN-CONS)
       ((M-Q) A-V-NIL)				;clear pointer to possible garbage
	((VMA-START-READ) ADD M-T A-K)		;Quotient may be 1 too long.
	(CHECK-PAGE-READ)
	((M-D) M-K)
	((M-E) M-D)
	(JUMP-NOT-EQUAL-XCT-NEXT MD A-ZERO BCLEANUP)
       ((M-C) SELECTIVE-DEPOSIT M-C BIGNUM-HEADER-SIGN A-K)
	(JUMP-XCT-NEXT BCLEANUP)
       ((M-E) SUB M-E (A-CONSTANT 1))

;Bignum-bignum remainder
; We enter with the first bignum in M-C the second in M-B and the header
; of the first still in MD.
REMAINDER-BIG-BIG
	((M-Q) M-C)
	((M-C) HEADER-REST-FIELD MD)
	((VMA-START-READ) M-B)
	(CHECK-PAGE-READ)
	((M-R) M-B)
	((M-I) BIGNUM-HEADER-LENGTH M-C)
	((M-J) BIGNUM-HEADER-LENGTH MD)
	;;If second bignum is longer than the first bignum then the answer is the first
	(JUMP-GREATER-THAN M-J A-I RETURN-M-Q)
	;;Sign of answer is already in M-C
	;;If second is one word long then do Bignum - Fixnum remainder
	(JUMP-GREATER-THAN M-J (A-CONSTANT 1) BIDIVR-2)
	((VMA-START-READ) ADD M-R (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-B) M-Q)
	((M-2) MD)
	((M-A) BIGNUM-HEADER-SIGN M-C)
	((M-C) BIGNUM-HEADER-LENGTH M-C)
	(CALL REMAINDER-BIG-FIX-1)
	(JUMP RETURN-M-1)

BIDIVR-2
	(CALL-XCT-NEXT BIDIV-REMAINDER-COMMON)
       ((M-A) A-ZERO)		;Indicate that quotient is not being saved.
	;;Now we have the remainder in M-Q,(M-I + 1) possibly shifted by
	;; an amount determined by
	;; the haulong still(!) in M-D. Sign of answer is still in M-C
	;;To shift back we perform an operation similar to BIDIV-NORMALIZE:
	;; First we LDB from the current word with: (M-K)
	;;		BYTL-1 = Haulong - 1
	;;		MROT = Haulong + 1
	;; Then we DPB into that from the next higher word with: (M-S)
	;;		BYTL-1 = 30. - haulong
	;;		MROT = Haulong
	(JUMP-EQUAL-XCT-NEXT M-D (A-CONSTANT 31.) BIDIVR-3)
       ((M-T) M-Q)
	((M-K) ADD M-D (A-CONSTANT 1))		;MROT
	((M-TEM) SUB M-D (A-CONSTANT 1))	;BYTL-1
	((M-K) DPB M-TEM OAL-BYTL-1 A-K)	;For LDB
	((M-TEM) (A-CONSTANT 30.))
	((M-TEM) SUB M-TEM A-D)			;BYTL-1, MROT in M-D
	((M-S) DPB M-TEM OAL-BYTL-1 A-D)	;For DPB
	((M-D) (A-CONSTANT 1))			;Counts through the bignum
	((M-E) (A-CONSTANT 1))			;Gets number of last non-zero word
	((VMA-START-READ) ADD M-T A-D)
	(CHECK-PAGE-READ)
	((M-1) MD)				;M-1 has word from last round.
BIDIVR-UNNORMALIZE-LOOP
	((VMA-START-READ) M+A+1 M-T A-D)
	(CHECK-PAGE-READ)
#+exp	((m-tem3) add m-k (a-constant 1_5))
#+exp	((oa-reg-low) (byte-field 10. 0) m-tem3)
#+lambda((OA-REG-LOW) M-K)
	((M-2) (BYTE-FIELD 0 0) M-1 A-ZERO)	;LDB out of lower word
	((M-1) MD)
#+exp	((m-tem3) add m-s (a-constant 1_5))
#+exp	((oa-reg-low) (byte-field 10. 0) m-tem3)
#+lambda((OA-REG-LOW) M-S)
	((MD M-2) DPB M-1 (BYTE-FIELD 0 0) A-2)	;DPB in from higher word
	((VMA-START-WRITE) ADD M-T A-D)		;Put back into lower word
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-EQUAL M-2 A-ZERO BIDIVR-UNNORMALIZE-1)
	((M-E) M-D)
BIDIVR-UNNORMALIZE-1
	(JUMP-LESS-THAN-XCT-NEXT M-D A-I BIDIVR-UNNORMALIZE-LOOP)
       ((M-D) ADD M-D (A-CONSTANT 1))
	(JUMP-XCT-NEXT BCLEANUP)
       ((M-C) SELECTIVE-DEPOSIT BIGNUM-HEADER-SIGN M-C A-D)

BIDIVR-3	;;In this case (no shifting necessary) we must loop downward looking
	;; for the first non-zero word.  Cannot share code with BIGNUM-DPB-CLEANUP.
	((M-D) ADD M-I (A-CONSTANT 1))
	((M-C) SELECTIVE-DEPOSIT BIGNUM-HEADER-SIGN M-C A-D)
	((M-E) M-D)				;Counts down bignum
BIDIVR-4	((VMA-START-READ) ADD M-T A-E)
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD A-ZERO BCLEANUP)
	(JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 2) BIDIVR-4)
       ((M-E) SUB M-E (A-CONSTANT 1))
	(JUMP BCLEANUP)			;Only one significant word

BIDIV-REMAINDER-COMMON 
	;;allocate a temporary bignum one word longer than first arg (put it in M-D)
	;; If Bignum remainder got us here then this bignum will BE the answer
	(call-xct-next allocate-bignum-storage)
       ((m-b) add m-i (a-constant 2))
	((M-TEM) ADD M-I (A-CONSTANT 1))
	((MD) ADD M-TEM (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					  (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-D) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(CHECK-PAGE-WRITE)
	;;Now do a haulong on the high order word of second arg (for normalization)
	;; note that if the answer is 31. then there is no need to normalize or allocate
	;; a second temporary bignum
	((VMA-START-READ) ADD M-R A-J)
	(CHECK-PAGE-READ)
	((M-T) A-ZERO)
	(CALL-XCT-NEXT XHAUL1)
       ((M-1) MD)
	(JUMP-EQUAL-XCT-NEXT M-T (A-CONSTANT 31.) BIDIV-PUNT-NORMALIZING)
       ((M-1) M-T)		;hide away haulong for later
	;;allocate another temporary bignum as long as the second and keep it in M-T
	(call-xct-next allocate-bignum-storage)
       ((m-b) add m-j (a-constant 1))
	((MD) ADD M-J (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-T) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(CHECK-PAGE-WRITE-UNBOXED)
	;;So now we build the proper constants from saved haulong in M-1
	;; for ldbing (in M-K) and dpbing (in M-S) to normalize (see comment in front
	;; of BIDIV-NORMALIZE)
	(CALL BIDIV-NORMALIZE-ENCODE-SHIFT)
	;;Perform normalization (subroutine takes old bignum in M-B and new in M-D
	;; steps length in M-ZR, bashes M-4)
	((M-E) A-ZERO)		;No offset for BIDIV-NORMALIZE.
	((M-B) M-Q)
	((M-ZR) M-I)
	(CALL-XCT-NEXT BIDIV-NORMALIZE)
       ((M-2) A-ZERO)
	((M-Q) M-D)		;Replace original dividend with copy
	;;Prepare to call it again:
	((VMA-START-READ) ADD M-R A-J)
	(CHECK-PAGE-READ)
	((M-D) M-T)
	((M-B) M-R)
#+exp	((m-tem3) add m-s (a-constant 1_5))
#+exp	((oa-reg-low) (byte-field 10. 0) m-tem3)
#+lambda((OA-REG-LOW) M-S)
	((M-2) DPB MD (BYTE-FIELD 0 0) A-ZERO)
	(CALL-XCT-NEXT BIDIV-NORMALIZE)
       ((M-ZR) SUB M-J (A-CONSTANT 1))
	(JUMP-XCT-NEXT BIDIV-READY)
       ((M-R) M-D)		;Replace original divisor with copy

BIDIV-PUNT-NORMALIZING
	;;In this case all we do is copy the first arg:
	((M-ZR) M-I)
BIDIV-PUNT-NORMALIZING-1
	((VMA-START-READ) ADD M-Q A-ZR)
	(CHECK-PAGE-READ)
	((WRITE-MEMORY-DATA) READ-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-D A-ZR)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-GREATER-THAN-XCT-NEXT M-ZR (A-CONSTANT 1) BIDIV-PUNT-NORMALIZING-1)
       ((M-ZR) SUB M-ZR (A-CONSTANT 1))
	((MD) A-ZERO)
	((VMA-START-WRITE) M+A+1 M-D A-I)
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-Q) M-D)		;Replace original dividend with copy
BIDIV-READY
	((M-T) M-A)		;Answer will wind up in M-T so why not now?
				;If remainder then this is a zero.
	((M-K) SUB M-I A-J)
	((M-K) ADD M-K (A-CONSTANT 1))
	((C-PDL-BUFFER-POINTER-PUSH) M-1)		;Saved haulong
	;;So now the situation is as follows: The sign of the answer is in
	;; BIGNUM-HEADER-SIGN in M-C. The old haulong of the top word of the second
	;; argument is on top of the PDL (We have to save
	;; that information so we know wether or not to un-cons!) We have a bignum
	;; in M-Q,(M-I + 1) that we are dividing by a normalized bignum in M-R,M-J.
	;; Answer is being built in M-T,M-K. (M-T = 0 if remaindering.)
	((M-S) M-K)			;M-S will count down through the answer
	((M-E) M-I)			;M-E will step down bignum in M-Q
	((VMA-START-READ) ADD M-R A-J)
	(CHECK-PAGE-READ)
	((A-BIDIV-V1) MD)				;V1
	((VMA-START-READ) SUB VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((A-BIDIV-V2) MD)				;V2
BIDIV-LOOP
	;;Now we are ready to make an estimate of what that first 31. bits will be.
	;;Comments are notation from Knuth.
	((VMA-START-READ) M+A+1 M-Q A-E)
	(CHECK-PAGE-READ)
	((M-3) MD)					;U0
	((VMA-START-READ) ADD M-Q A-E)
	(CHECK-PAGE-READ)
	(JUMP-EQUAL M-3 A-BIDIV-V1 BIDIV-SIMPLE-CASE)
	((M-TEM) DPB M-3 (BYTE-FIELD 1 31.) A-ZERO)
	((Q-R) IOR MD A-TEM)				;low 32. bits of U0 * B + U1
	((M-3) (BYTE-FIELD 30. 1) M-3 A-ZERO)		;high 30. bits of same
	((M-1) A-BIDIV-V1)				;Divide by V1
	;; Compute QHAT = Floor((U0 * B + U1) / V1) and RHAT = U0 * B + U1 - QHAT * V1
	((M-3) DIVIDE-FIRST-STEP M-3 A-1)
(REPEAT 31. ((M-3) DIVIDE-STEP M-3 A-1))
	((M-3) DIVIDE-LAST-STEP M-3 A-1)
	((M-3) DIVIDE-REMAINDER-CORRECTION-STEP M-3 A-1);RHAT
	(JUMP-XCT-NEXT BIDIV-OPTIMIZE-QHAT)
       ((M-1) Q-R)					;QHAT

BIDIV-SIMPLE-CASE
	((M-1) (A-CONSTANT 17777777777))		;QHAT = B - 1
	((M-3) ADD MD A-BIDIV-V1)			;RHAT = U1 + V1
	;; If sign bit of M-3 is set then we know that RHAT * B + U2 is greater
	;; than QHAT * V2:
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 31.) M-3 BIDIV-QHAT-IS-GOOD)
BIDIV-OPTIMIZE-QHAT
	;;Now in order to check if RHAT * B + U2 < QHAT * V2 we first read in U2
	;; and then compute QHAT * V2 .
	((M-TEM) SUB M-E (A-CONSTANT 1))
	((VMA-START-READ) ADD M-Q A-TEM)
	(CHECK-PAGE-READ)
	((Q-R) A-BIDIV-V2)
	(CALL-XCT-NEXT MPY)
       ((M-4) MD)					;U2
	((M-2) M-2 OUTPUT-SELECTOR-LEFTSHIFT-1)		;BRING IN HIGH BIT OF Q
	;;Now M-2 = High(QHAT * V2)
	;;    M-3 = RHAT = High(RHAT * B + U2)
	;;    M-4 = U2 = Low(RHAT * B + U2)
	;;    M-1 = QHAT
	;;    Q-R = Low(QHAT * V2) plus junk in sign bit
	(JUMP-GREATER-THAN M-3 A-2 BIDIV-QHAT-IS-GOOD)
	((M-TEM) (BYTE-FIELD 31. 0) Q-R A-ZERO)		;Low(QHAT * V2)
	(JUMP-LESS-THAN M-3 A-2 BIDIV-OPTIMIZE-QHAT-SUB1)
	(JUMP-GREATER-OR-EQUAL M-4 A-TEM BIDIV-QHAT-IS-GOOD)
BIDIV-OPTIMIZE-QHAT-SUB1
	;; So QHAT must be decremented and other quantities adjusted:
	((M-TEM) SUB M-TEM A-BIDIV-V2)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 31.) M-TEM BIDIV-2);carry into High(QHAT * V2)
       ((M-3) ADD M-3 A-BIDIV-V1)			;Adjust RHAT
	((M-TEM) (BYTE-FIELD 31. 0) M-TEM A-ZERO)
	((M-2) SUB M-2 (A-CONSTANT 1))
BIDIV-2
 	;;If M-3 is negative then RHAT * B + U2 overflew and must be greater than
	;; QHAT * V2
	(JUMP-IF-BIT-SET-XCT-NEXT (BYTE-FIELD 1 31.) M-3 BIDIV-QHAT-IS-GOOD)
       ((M-1) SUB M-1 (A-CONSTANT 1))			;Decrement QHAT
	(JUMP-GREATER-THAN M-3 A-2 BIDIV-QHAT-IS-GOOD)
	(JUMP-LESS-THAN M-3 A-2 BIDIV-OPTIMIZE-QHAT-SUB2)
	(JUMP-GREATER-OR-EQUAL M-4 A-TEM BIDIV-QHAT-IS-GOOD)
BIDIV-OPTIMIZE-QHAT-SUB2
	((M-1) SUB M-1 (A-CONSTANT 1))			;Decrement QHAT second time.
BIDIV-QHAT-IS-GOOD
	;;QHAT contains the wrong thing only once every 716 million times!
	;;We multiply divisor by QHAT and subtract from dividend
	((M-A) (A-CONSTANT 1))			;steps through M-R
	((M-B) SUB M-E A-J)
	((M-B) ADD M-B (A-CONSTANT 1))		;steps through M-Q
	((M-ZR) A-ZERO)				;borrow from last round
	((M-2) A-ZERO)				;for multiplication scratch
BIDIV-MPY-LOOP
	((VMA-START-READ) ADD M-R A-A)
	(CHECK-PAGE-READ)
	((Q-R) MD)
(REPEAT 31. ((M-2) MULTIPLY-STEP M-2 A-1))
	((M-D) (BYTE-FIELD 31. 1) Q-R A-ZERO)	;Now M-D might contain gubbish.
	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-TEM) SUB MD A-D)
	((M-TEM) SUB M-TEM A-ZR)
	((MD) (BYTE-FIELD 31. 0) M-TEM A-ZERO)
	((M-ZR) (BYTE-FIELD 1 31.) M-TEM A-ZERO)
	((VMA-START-WRITE) ADD M-Q A-B)
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-A) ADD M-A (A-CONSTANT 1))
	(JUMP-LESS-THAN-XCT-NEXT M-B A-E BIDIV-MPY-LOOP)
       ((M-B) ADD M-B (A-CONSTANT 1))
	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-4) SUB MD A-2)
	((MD-START-WRITE M-4) SUB M-4 A-ZR)
	(CHECK-PAGE-WRITE-UNBOXED)
	(CALL-IF-BIT-SET (BYTE-FIELD 1 31.) M-4 BIDIV-ONCE-IN-716MILLION) ;DAMN! QHAT too big.
	(JUMP-EQUAL-XCT-NEXT M-T A-ZERO BIDIV-DONT-STORE)	;write QHAT into quotient
       ((M-E) SUB M-E (A-CONSTANT 1))				;If not remaindering
	((MD) M-1)
	((VMA-START-WRITE) ADD M-T A-S)
	(CHECK-PAGE-WRITE-UNBOXED)
BIDIV-DONT-STORE
	(JUMP-GREATER-THAN-XCT-NEXT M-S (A-CONSTANT 1) BIDIV-LOOP)
       ((M-S) SUB M-S (A-CONSTANT 1))
	;;Now we have the answer so we give up any temp. storage and cleanup the answer.
	((M-D) C-PDL-BUFFER-POINTER-POP)	;Clears any gubbish from M-D
	;;Now M-D contains the haulong of high word of original M-R
	(POPJ-EQUAL M-D (A-CONSTANT 31.))
	((M-1) M-R)
	((M-2) ADD M-J (A-CONSTANT 1))
	(JUMP-XCT-NEXT UN-CONS)			;Tail recursive call
       ((M-R) A-V-NIL)				;clear pointer to possible garbage

;;We come here in the case where QHAT was 1 too large, we must add divisor back into
;; dividend once.
BIDIV-ONCE-IN-716MILLION
	((M-A) (A-CONSTANT 1))			;steps through M-R
	((M-B) SUB M-E A-J)
	((M-B) ADD M-B (A-CONSTANT 1))		;steps through M-Q
	((M-ZR) A-ZERO)				;carry
BIDIV-ONCE-IN-716MILLION-1
	((VMA-START-READ) ADD M-R A-A)
	(CHECK-PAGE-READ)
	((M-4) ADD MD A-ZR)
	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-4) ADD MD A-4)
	((M-ZR) (BYTE-FIELD 1 31.) M-4 A-ZERO)
	((MD-START-WRITE) (BYTE-FIELD 31. 0) M-4 A-ZERO)
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-A) ADD M-A (A-CONSTANT 1))
	(JUMP-LESS-THAN-XCT-NEXT M-B A-E BIDIV-ONCE-IN-716MILLION-1)
       ((M-B) ADD M-B (A-CONSTANT 1))
	((MD) A-ZERO)		;Keep remainder correct.
	((VMA-START-WRITE) ADD M-Q A-B)
	(CHECK-PAGE-WRITE-UNBOXED)
	(POPJ-AFTER-NEXT (M-1) SUB M-1 (A-CONSTANT 1))	;decrement QHAT
       (NO-OP)

;;; Set up args for the below from shift in M-1
BIDIV-NORMALIZE-ENCODE-SHIFT
	((M-TEM) SUB (M-CONSTANT 32.) A-1)	;MROT = 32. - Haulong
	((M-K) SUB M-TEM (A-CONSTANT 2))	;BYTL-1 = 30. - Haulong
	((M-K) DPB M-K OAL-BYTL-1 A-TEM)	;M-K constant for LDBing
	((M-TEM) SUB M-TEM (A-CONSTANT 1))	;MROT = 31. -Haulong
	(POPJ-AFTER-NEXT
	 (M-S) SUB M-1 (A-CONSTANT 1))		;BYTL-1 = Haulong - 1
       ((M-S) DPB M-S OAL-BYTL-1 A-TEM)		;M-S constant for DPBing

;;; Subroutine for normalizing bignums:
;;; Does a left shift using M-K to ldb from C(M-B + M-ZR) into M-2 and stored at
;;; (M-D + A-ZR + 1 + M-E), and then dpb using M-S from C(M-B + M-ZR) into M-2 for the
;;; next time around:
;;;
;;;	|0| X |  Y  |	becomes:	|0|  Y  |   |  ;left in M-2 for next round.
;;;	|0|   |     |			|0|     | X |  ;written out with high half
;;;						       ; from last round.
;;; 
;;; M-K is the LDB pointer for X.  The thing initially in M-1 is the width of Y.
;;; M-S is the DPB pointer for Y.
;;;
;;; M-4 is bashed. M-2 can be loaded with whatever you want in the high part of the
;;; first word written (at M-D + M-ZR + 1 + M-E), you also load M-ZR
;;;Note that M-E is an offset in words to shift the bignum, that many words of zeros
;;; will be placed in the low bits of the bignum in M-D.
;;;This is crocked to work if M-E is 0, but not if it is negative!
;;; But -1 in M-E causes the bottom word (the final Y) of the bignum
;;; in M-D to disappear (for ASH).
BIDIV-NORMALIZE
	(JUMP-EQUAL M-ZR A-ZERO BIDIV-NORMALIZE-0)
	((VMA-START-READ) ADD M-B A-ZR)
	(CHECK-PAGE-READ)
#+exp	((m-tem3) add m-k (a-constant 1_5))
#+exp	((oa-reg-low) (byte-field 10. 0) m-tem3)
#+lambda((OA-REG-LOW) M-K)
	((M-4) (BYTE-FIELD 0 0) MD A-2)
#+exp	((m-tem3) add m-s (a-constant 1_5))
#+exp	((oa-reg-low) (byte-field 10. 0) m-tem3)
#+lambda((OA-REG-LOW) M-S)
	((M-2) DPB MD (BYTE-FIELD 0 0) A-ZERO)
	((MD) M-4)
	((M-4) ADD M-ZR A-E)
	((VMA-START-WRITE) M+A+1 M-D A-4)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-GREATER-THAN-XCT-NEXT M-ZR (A-CONSTANT 1) BIDIV-NORMALIZE)
       ((M-ZR) SUB M-ZR (A-CONSTANT 1))
BIDIV-NORMALIZE-0
	(POPJ-LESS-THAN M-E A-ZERO)
	((MD) M-2)
	((VMA-START-WRITE) M+A+1 M-D A-E)
       	(CHECK-PAGE-WRITE-UNBOXED)
	(POPJ-EQUAL M-E A-ZERO)
	((MD) A-ZERO)
BIDIV-NORMALIZE-1
	((VMA-START-WRITE) ADD M-D A-E)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 1) BIDIV-NORMALIZE-1)
       ((M-E) SUB M-E (A-CONSTANT 1))
	(POPJ)

ARITH-FIX-BIG
	((M-2) M-1)	;UNPACKED FIXNUM ARG
	((M-Q) M-T)	;BIGNUM ITSELF (SECOND ARG)
	((M-C) M-D)	;BIGNUM HEADER
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-A D-FIXNUM-BIGNUM-OPS)
       ((M-I) M-J)      ;BIGNUM LENGTH

(LOCALITY D-MEM)
;FIXNUM IN BOTH M-1, M-2.  BIGNUM IN BOTH M-Q, M-T.  HEADER IN M-C, M-D.  LENGTH IN M-I, M-J.
(START-DISPATCH 4 0)
D-FIXNUM-BIGNUM-OPS
	(FXBADD)
	(FXBSUB)
	(FXBMPY)
	(FXBIDIV)
	(XFALSE)			;Fixnum = Bignum ???
	(FXBGRP)
	(FXBLSP)
	(FXBMIN)
	(FXBMAX)
	(FXBBOOLE)
	(FXBDIV)
	(XFALSE)			;Fixnum = Bignum ???
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

ARITH-BIG-FIX
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-A D-BIGNUM-FIXNUM-OPS)
       (NO-OP)

(LOCALITY D-MEM)
;FIXNUM IN M-T, UNPACKED INTO M-2.
;BIGNUM IN M-Q, HEADER IN M-C, LENGTH IN M-I.
(START-DISPATCH 4 0)
D-BIGNUM-FIXNUM-OPS
	(BFXADD)
	(BFXSUB)
	(BFXMPY)
	(BFXIDIV)
	(XFALSE)			;Bignum = Fixnum ???
	(BFXGRP)
	(BFXLSP)
	(BFXMIN)
	(BFXMAX)
	(BFXBOOLE)
	(BFXDIV)
	(XFALSE)			;Bignum = Fixnum ???
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

FXBSUB	(JUMP-XCT-NEXT FXBADD0)
       ((M-C) XOR M-C (A-CONSTANT (BYTE-VALUE BIGNUM-HEADER-SIGN 1)))

FXBRETQ	(POPJ-AFTER-NEXT	;RETURN BIGNUM ARG.
	 (M-T) Q-TYPED-POINTER M-Q)
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE   ;LEAVE RESULT BOTH PLACES
			 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))  ;FOR GOOD MEASURE.

BFXSUB	((M-2) SUB M-ZERO A-2)	;NO SETZ PROBLEMS!
BFXADD 
FXBADD	(JUMP-EQUAL M-2 A-ZERO FXBRETQ)  ;SPECIAL CASE IF ADDING ZERO, JUST RETURN OTHER GUY
FXBADD0	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-2 A-ZERO BFXADD-1)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
	((M-2) SUB M-ZERO A-2)			;Make positive
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BFXADD-ADD)
BFXADD-SUB	;M-Q/M-I bignum, M-2 positive number to be subtracted
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 1))
	((M-D) M-I)
	((M-B) (A-CONSTANT 1))
	(JUMP-XCT-NEXT BSUB-C)
       ((M-E) (A-CONSTANT 1))

BFXADD-1
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BFXADD-SUB)
BFXADD-ADD	;M-Q/M-I bignum, M-2 positive number to be added
	(CALL-XCT-NEXT BNCONS)			;ALLOCATE IN STRUCTURE EXTRA-PDL
       ((M-B) ADD M-I (A-CONSTANT 2))
	((M-I) ADD M-I (A-CONSTANT 1))
	((M-R) M-Q)
	((M-J) SUB M-I (A-CONSTANT 1)) ;Recover length of bignum in M-Q (M-R)
	(JUMP-XCT-NEXT BADD5)
       ((M-D) (A-CONSTANT 1))

BIGNUM-ADD1
	(JUMP-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-C BFXADD-ADD)
       ((M-2) (A-CONSTANT 1))
	(JUMP BFXADD-SUB)

BIGNUM-SUB1
	(JUMP-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-C BFXADD-SUB)
       ((M-2) (A-CONSTANT 1))
	(JUMP BFXADD-ADD)

RETURN-ZERO
	(POPJ-AFTER-NEXT (M-T C-PDL-BUFFER-POINTER-PUSH)
		(A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
				  (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
       (NO-OP)

;; A fixnum multiplied by a bignum can yield a fixnum in just two cases(!):
BFXMPY 
FXBMPY	(JUMP-EQUAL M-2 A-ZERO RETURN-ZERO)	;0*X=0
	(JUMP-NOT-EQUAL M-2 A-MINUS-ONE BFXMPY-OK)	;(-1)*(+SETZ)=(-SETZ)
	(JUMP-NOT-EQUAL M-I (A-CONSTANT 1) BFXMPY-OK)
	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD (A-CONSTANT POSITIVE-SETZ) BFXMPY-OK)
	(POPJ-AFTER-NEXT (M-T C-PDL-BUFFER-POINTER-PUSH)
		Q-POINTER MD (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
					       (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
       (NO-OP)

BFXMPY-OK
	(JUMP-GREATER-OR-EQUAL M-2 A-ZERO BFXMPY-1)
	((M-2) SUB M-ZERO A-2)			;NEGATIVE FIXNUM, CHANGE SIGN OF RESULT
	((M-C) XOR M-C (A-CONSTANT (BYTE-VALUE BIGNUM-HEADER-SIGN 1)))
BFXMPY-1
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 2))
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
					 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	(CALL-XCT-NEXT MULTIPLY-ONCE)
       ((M-1) A-ZERO)
	((MD) M-1)
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE-UNBOXED)
	(POPJ-NOT-EQUAL M-1 A-ZERO)
	((M-C) SUB M-C (A-CONSTANT 1))
	((MD) ADD M-C (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE-UNBOXED)
	((M-1) ADD M-T A-D)
	(JUMP-XCT-NEXT UN-CONS)
       ((M-2) (A-CONSTANT 1))

;; MULTIPLY-ONCE multiplies a bignum in M-Q,M-I by a fixnum in M-2 and adds the fixnum in M-1.
;; Writes answer M-T (as if it is a bignum). Leaves last word (not written) in M-1.
;; Bashes M-D to be M-I + 1
MULTIPLY-ONCE
	((M-D) (A-CONSTANT 1))
BFXMPY-LOOP
	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((Q-R) MD)
(REPEAT 31. ((M-1) MULTIPLY-STEP M-1 A-2))
	((M-1) (BYTE-FIELD 31. 0) M-1)
	((MD) (BYTE-FIELD 31. 1) Q-R)
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-LESS-THAN-XCT-NEXT M-D A-I BFXMPY-LOOP)
       ((M-D) ADD M-D (A-CONSTANT 1))
	(POPJ)

;Bignum in M-Q divided by bignum in M-B to give rational, returned on stack.
BDIV
	((PDL-PUSH) M-Q)
	((PDL-PUSH) M-B)
	((PDL-PUSH) M-Q)
	((PDL-PUSH) M-B)
;This really should do the division once getting a quotient and remainder
;so it only has to be done once if the quotient comes out even.
	(CALL XGCD)		;Get GCD into M-T.
	(JUMP NORMALIZED-RATIONAL-TO-STACK)

;Fixnum (unpacked in M-2) divided by bignum (in M-T and M-Q) to give a rational (on stack).
;The bignum's header is in M-C.
FXBDIV
	(JUMP-EQUAL M-2 A-ZERO QDIV-ZERO)
	((M-1) M-2)
	(CALL FIXPACK-P)	;Push packed fixnum, then push the bignum.
	((PDL-PUSH) M-Q)
	((VMA-START-READ M-B) M-Q)
	(CHECK-PAGE-READ)
	(CALL GCD-FIX-BIG)
	(JUMP NORMALIZED-RATIONAL-TO-STACK)
	
;Bignum (in M-Q) divided by fixnum (unpacked in M-2) to give rational (on stack).
BFXDIV
	((M-T PDL-PUSH) Q-TYPED-POINTER M-Q);Must not push after popj'ing since next insn may pop.
	(POPJ-EQUAL M-2 (A-CONSTANT 1))
	((M-1) M-2)
	(CALL FIXPACK-P)	;Put fixnum on stack and in M-T.
	((PDL-PUSH) M-Q)
	(CALL BFXDIV1)
	(PDL-POP)
;If remainder is 0, just return the quotient (which is in M-T).
	(JUMP-EQUAL M-3 A-ZERO BFXDIV-EVEN)
;Stack now has bignum, fixnum.  M-3 has remainder from division.
	((M-1) M-3)
	((M-2) OUTPUT-SELECTOR-EXTEND-25 PDL-TOP)
	(CALL GCD-FIX-FIX)
	(JUMP NORMALIZED-RATIONAL-TO-STACK)

BFXDIV-EVEN
	(POPJ-AFTER-NEXT PDL-POP)
       ((PDL-TOP) M-T)

;Make a rational number from two nonzero boxed args (num and denom) on the stack,
;given their gcd in M-T.  The value is returned on the stack.
NORMALIZED-RATIONAL-TO-STACK
	(JUMP-EQUAL-XCT-NEXT M-T (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 1))
		NORMALIZED-RATIONAL-ALREADY)
       ((M-A) PDL-POP)
	((PDL-PUSH) M-T)
	((PDL-PUSH) M-A)
;Stack now has arg 1, gcd, arg 2.  M-T has gcd.
	(CALL QIDIV)
;Stack now has arg 1, gcd, final denominator.
	((M-A) SETA PDL-POP A-T)	;Pop stack, get value from M-T.
				;The same value is in both places, but pdl was just written.
	((M-A) Q-TYPED-POINTER M-A)
	((M-T) PDL-POP)
	((M-1) PDL-POP)
	(JUMP-EQUAL M-A (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 1))
		NORMALIZED-RATIONAL-IS-INTEGER)
	(JUMP-EQUAL M-A (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
					  (BYTE-MASK BOXED-SIGN-BIT)
					  (BYTE-MASK BOXED-NUM-EXCEPT-SIGN-BIT)))
		NORMALIZED-RATIONAL-IS-INTEGER-BUT-NEGATE)
	((PDL-PUSH) M-A)
	((PDL-PUSH) M-1)
;Stack now has final denominator, arg 1; M-T has gcd.
	(CALL QIDIV)
;Stack now has final denominator, final numerator.  Numerator also in M-T.
;If denominator is negative, change both signs.
NORMALIZED-RATIONAL-FIX-SIGNS
	((M-J) SETA PDL-POP A-T)	;Pop stack, but get from M-T
				;since the stack was possibly pushed on previous cycle.
	((PDL-PUSH) PDL-TOP)
	(CALL XMINUSP)
	(JUMP-EQUAL M-T A-V-NIL NORMALIZED-RATIONAL-RIGHT-SIGNS)
	(CALL XMINUS)
	((PDL-PUSH) M-T)
	((PDL-PUSH) M-J)
	(CALL XMINUS)
	((M-J) M-T)
NORMALIZED-RATIONAL-RIGHT-SIGNS
	((PDL-PUSH) M-J)
	(JUMP-XCT-NEXT MAKE-RATIONAL)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))

;Jump here if GCD is 1.  Numerator on stack, denom in M-A.
NORMALIZED-RATIONAL-ALREADY
	((M-T) PDL-POP)
	((PDL-PUSH) M-A)
	((PDL-PUSH) M-T)
;Stack now has final denominator, final numerator.
	(JUMP NORMALIZED-RATIONAL-FIX-SIGNS)

;Jump here if GCD equals the denominator.	
NORMALIZED-RATIONAL-IS-INTEGER
	((PDL-PUSH) M-1)	;Divide the 1st arg by the gcd
	(JUMP QIDIV)		;and return, leaving that on the stack as the answer.

;Here if the GCD is minus the demoninator.
NORMALIZED-RATIONAL-IS-INTEGER-BUT-NEGATE
	(CALL-XCT-NEXT QIDIV)
       ((PDL-PUSH) M-1)
	(JUMP-XCT-NEXT XMINUS)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))

;Bignum divided by a fixnum to give an integer quotient on the stack.
;A remainder, in unpacked form, is in M-K.
BFXIDIV
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
BFXDIV1
	(CALL-EQUAL M-2 A-ZERO TRAP)
		(ERROR-TABLE DIVIDE-BY-ZERO)
		(ERROR-TABLE ARG-POPPED M-Q M-T)
	(JUMP-GREATER-THAN M-2 A-ZERO BFXIDIV-1)
	((M-C) XOR M-C (A-CONSTANT (BYTE-VALUE BIGNUM-HEADER-SIGN 1)))	;If fixnum is negative
	((M-2) SUB M-ZERO A-2)	;then change sign of both args.
BFXIDIV-1
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 1))
	((M-R) M-T)
	(CALL-XCT-NEXT DIVIDE-ONCE)	;divide once stores into bignum in M-R,M-J
       ((M-J) M-I)
	((M-D) M-I)		;current length
	((VMA-START-READ) ADD M-T A-D)	;read last word to see if it is zeros
	(CHECK-PAGE-READ)
	((M-3) M-1)		;save remainder.  Can not do this in a typed register.
	(JUMP-NOT-EQUAL-XCT-NEXT MD A-ZERO BCLEANUP)	;not zeros
       ((M-E) M-D)
	(JUMP-XCT-NEXT BCLEANUP)	;zeros so length should be M-D - 1
       ((M-E) SUB M-E (A-CONSTANT 1))

;; DIVIDE-ONCE divides bignum in M-Q,M-I by positive(!) number in M-2.
;; bashes M-1 M-3 M-TEM M-D
;; answer is stored in M-R,M-J
;; remainder is left in M-1
DIVIDE-ONCE
	((M-1) A-ZERO)
	((M-3) (A-CONSTANT 1))
	((M-D) M-I)
DIVIDE-ONCE-L
	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((M-TEM) DPB M-3 (BYTE-FIELD 30. 1) A-ZERO)
	((M-TEM1) DPB MD (BYTE-FIELD 31. 1) A-3)
 #+lambda ((m-garbage) divide-first-step m-zero a-zero)  ;load hardware divisor sign register!
	((Q-R) A-TEM1)
(REPEAT 31. ((M-1) DIVIDE-STEP M-1 A-2))
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-D A-J DIVIDE-ONCE-1)
       ((M-3) Q-R)			;Save Q-R which is bashed by page faults
	((MD) (BYTE-FIELD 1 30.) Q-R A-TEM)
	((VMA-START-WRITE) M+A+1 M-R A-D)
	(CHECK-PAGE-WRITE-UNBOXED)
DIVIDE-ONCE-1
	(JUMP-GREATER-THAN-XCT-NEXT M-D (A-CONSTANT 1) DIVIDE-ONCE-L)
       ((M-D) SUB M-D (A-CONSTANT 1))
	((Q-R) M-3)
	((M-1) DIVIDE-LAST-STEP M-1 A-2)
	((M-1) DIVIDE-REMAINDER-CORRECTION-STEP M-1 A-2)
	((MD) (BYTE-FIELD 31. 0) Q-R)
	(POPJ-AFTER-NEXT (VMA-START-WRITE) ADD M-R (A-CONSTANT 1))
       (CHECK-PAGE-WRITE-UNBOXED)

;Fixnum divided by bignum is 0 except for -setz over +setz which is -1
FXBIDIV
	(POPJ-NOT-EQUAL-XCT-NEXT M-2 (A-CONSTANT NEGATIVE-SETZ))
       ((M-T C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
							  (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	(POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
	(POPJ-NOT-EQUAL M-I (A-CONSTANT 1))
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT POPJ-NOT-EQUAL MD (A-CONSTANT POSITIVE-SETZ))
       ((M-T C-PDL-BUFFER-POINTER) DPB M-MINUS-ONE Q-POINTER A-T)

BFXGRP 
FXBLSP
	((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
       ((M-T) A-V-TRUE)

BFXLSP 
FXBGRP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
       ((M-T) A-V-NIL)

BFXMIN 
FXBMIN
	((M-T) M-Q)			;neg. bignums are less than fixnums!
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
       ((M-T) DPB M-2 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	
BFXMAX 
FXBMAX
	((M-T) M-Q)			;positive bignums are greater than fixnums!
	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR BIGNUM-HEADER-SIGN M-C)
       ((M-T) DPB M-2 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))


;; First arg a bignum second a fixnum.  The bignum is expressed in the base of the fixnum
;; and stuffed in to an appropriate art-q array.
(MISC-INST-ENTRY BIGNUM-TO-ARRAY)
BIG-TO-ARY
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-Q) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
    (ERROR-TABLE RESTART BIG-TO-ARY)
	(CALL-DATA-TYPE-NOT-EQUAL M-Q
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)) TRAP)
    (ERROR-TABLE ARGTYP BIGNUM M-Q 0 BIG-TO-ARY)
    (ERROR-TABLE ARG-POPPED 0 M-Q M-A)
	(DISPATCH Q-DATA-TYPE M-A TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM M-A 1 BIG-TO-ARY)
    (ERROR-TABLE ARG-POPPED 0 M-Q M-A)
	((VMA-START-READ) M-Q)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-TEM) HEADER-TYPE-FIELD MD)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM)) TRAP)
    (ERROR-TABLE ARGTYP BIGNUM M-Q 0 BIG-TO-ARY)
    (ERROR-TABLE ARG-POPPED 0 M-Q M-A)
	((M-Q) VMA)		;get transported number address 
	((M-I) BIGNUM-HEADER-LENGTH MD)
	((M-1) Q-POINTER M-A)
	(CALL-XCT-NEXT XHAUL1)	;M-T gets number of bits in M-A LESS ONE(!)
       ((M-T) A-MINUS-ONE)
	;; we must allocate an array at least 31*I/T long
	;; 31*I = 32*I - I
	((M-1) DPB M-I (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 5)) 5) A-ZERO)
	((M-1) SUB M-1 A-I)
	(CALL-XCT-NEXT DIV)
       ((M-2) Q-POINTER M-T)
	(JUMP-EQUAL-XCT-NEXT M-1 A-ZERO BIG-TO-ARY-1)	;If no remainder then we are o.k.
       ((M-C) Q-R)
	((M-C) ADD M-C (A-CONSTANT 1))	;with remainder then allocate 1 more
BIG-TO-ARY-1
;	(CALL-XCT-NEXT SCONS-D)	;Allocate space for art-q array
;      ((M-B) ADD M-C (A-CONSTANT 2))
     ;; Allocate (+ M-C 2) words of boxed structure storage.
        ((pdl-push) m-a)	;Cons routines now clobber M-A.
        ((m-b) add m-c (a-constant 2))
        (call-xct-next allocate-structure-storage-default)
       ((m-a) m-b)
	((m-a) pdl-pop)		;Restore M-A.
	((MD) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-HEADER)
				(BYTE-VALUE %%ARRAY-NUMBER-DIMENSIONS 1)
				(BYTE-VALUE %%ARRAY-LONG-LENGTH-FLAG 1)
				(EVAL ART-Q))))
	((VMA-START-WRITE M-R) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER)))
	(CHECK-PAGE-WRITE)
	((MD) Q-POINTER M-C (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) ADD M-R (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	;; now we have the array in M-R with length in M-C
	;; we must now allocate a bignum to divide into.
	(call-xct-next allocate-bignum-storage)
       ((m-b) add m-i (a-constant 1))
	((MD) ADD M-I (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-T) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(CHECK-PAGE-WRITE-UNBOXED)
	;; now we have a (temp.) bignum in M-T so we start to divide
	((M-E) M-R)		;move the array into M-E
;	((M-B) M-I)		;save length of bignum
	((M-2) Q-POINTER M-A)	;fixnum to divide by
	((M-A) (A-CONSTANT 1))	;index+1 into array
	((M-R) M-T)
	(CALL-XCT-NEXT DIVIDE-ONCE)
       ((M-J) M-I)
	((M-Q) M-R)		;from now on we divide from the temp bignum to itself.
BIG-TO-ARY-L
	((MD) Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) M+A+1 M-E A-A)	;write remainder.
	(CHECK-PAGE-WRITE-UNBOXED)
	((VMA-START-READ) ADD M-R A-J)	;Check to see if last word of quotient was zero.
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD A-ZERO BIG-TO-ARY-2)
	(JUMP-EQUAL M-I (A-CONSTANT 1) BIG-TO-ARY-CLEANUP)	;bignum is zero, done
	((M-I) SUB M-I (A-CONSTANT 1))	;pretend bignum is shorter
BIG-TO-ARY-2
	(CALL-XCT-NEXT DIVIDE-ONCE)
       ((M-J) M-I)
	(JUMP-XCT-NEXT BIG-TO-ARY-L)
       ((M-A) ADD M-A (A-CONSTANT 1))

BIG-TO-ARY-CLEANUP
	((M-T) M-E)		;array to return
;	((M-1) M-R)
;	((M-D) M-A)		;M-A smashed by UN-CONS
;	(CALL-XCT-NEXT UN-CONS)	;Give back the bignum
;      ((M-2) ADD M-B (A-CONSTANT 1))
	(POPJ-EQUAL M-C A-a)	;all array used so return it!
	;; else give back unused end of array
	((MD) Q-POINTER M-a (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE M-1) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	((M-1) M+A+1 M-1 A-a)
	(JUMP-XCT-NEXT UN-CONS)	;tail recursive call
       ((M-2) SUB M-C A-a)


;; First arg a art-q array second a fixnum third the sign bit (zero or one).
;; Returns a bignum. Inverse of BIGNUM-TO-ARRAY
(MISC-INST-ENTRY ARRAY-TO-BIGNUM)
(ERROR-TABLE DEFAULT-ARG-LOCATIONS ARRAY-TO-BIGNUM PP M-J M-C)
ARY-TO-BIG
	((M-C) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;sign bit.
	((M-J) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;fixnum.
    (ERROR-TABLE RESTART ARY-TO-BIG)
	(DISPATCH Q-DATA-TYPE M-C TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM M-C 2 ARY-TO-BIG)
	(DISPATCH Q-DATA-TYPE M-J TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM M-J 1 ARY-TO-BIG)
	((M-C) DPB M-C BIGNUM-HEADER-SIGN A-ZERO)
	((M-J) Q-POINTER M-J)
	(CALL-XCT-NEXT GAHDR)			;array.
       ((m-array-pointer) invalidate-array-cache c-pdl-buffer-pointer-pop)
	(call store-array-registers-in-accumulators)
	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) m-b trap)
    (ERROR-TABLE ARGTYP NON-DISPLACED-ARRAY PP 0)
	((M-B) SELECTIVE-DEPOSIT M-b (LISP-BYTE %%ARRAY-TYPE-FIELD) A-ZERO)
	(CALL-NOT-EQUAL M-B (A-CONSTANT (EVAL ART-Q)) trap)
    (ERROR-TABLE ARGTYP ART-Q-ARRAY PP 0)
	(CALL-NOT-EQUAL M-D (A-CONSTANT 1) trap)
    (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 1 PP)
	;; now we have the array in M-A (origin in M-E, length in M-S)
	;; sign bit in correct spot in M-C
	;; fixnum in M-J (unboxed)
	((M-T) A-ZERO)
	(CALL-XCT-NEXT XHAUL1)			;Get # bits per array element
       ((M-1) M-J)
	((M-1) M-T)				;Size of bignum in bits
	(CALL-XCT-NEXT MPY)
       ((Q-R) m-s)
	(CALL-NOT-EQUAL M-2 A-ZERO trap)
		(ERROR-TABLE ARGTYP REASONABLE-SIZE-ARRAY M-A)
	((M-1) Q-R)
	(CALL-XCT-NEXT DIV)			;Get size of bignum in words
       ((M-2) (A-CONSTANT 31.))
	((M-I) ADD Q-R (A-CONSTANT 1))
	;; we have now computed the amount of space to allocate for the bignum.
	;; The formula is I := 1+(haulong J)*S/31.
	((M-R) M-E)		;shuffle (origin of array)
	((M-D) M-S)		;suuffle (length of array)
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 1))
	((M-S) M-D)		;unshuffle (length of array)
	((M-2) M-J)		;"radix"
	;; now we have the array in M-A (origin in M-R length in M-S),
	;; we have the fixnum in M-2, we have the bignum in M-T (header in M-C, length in M-I)
	;; first we must zero the bignum.
	((M-D) (A-CONSTANT 1))
	((MD) A-ZERO)
ARY-TO-BIG-2
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE-UNBOXED)
	(JUMP-LESS-THAN-XCT-NEXT M-D A-I ARY-TO-BIG-2)
       ((M-D) ADD M-D (A-CONSTANT 1))
	((M-Q) M-T)		;copy in M-Q
	;; now we start:
	((M-S) SUB M-S (A-CONSTANT 1))
ARY-TO-BIG-L
	((VMA-START-READ) ADD M-R A-S)
	(CHECK-PAGE-READ)
	(CALL-XCT-NEXT MULTIPLY-ONCE)
       ((M-1) Q-POINTER MD)
	(CALL-NOT-EQUAL M-1 A-ZERO ILLOP)	;overflow (should never happen)
	(JUMP-GREATER-THAN-XCT-NEXT M-S A-ZERO ARY-TO-BIG-L)
       ((M-S) SUB M-S (A-CONSTANT 1))
	;; now we see how many zeros we have at the end
BIGNUM-DPB-CLEANUP	;Enters here with bignum in M-T, header in M-C
			;Use this only for logical operations, not arithmetic
			; ones!  Note the treatment of negative zero!
	((M-E) BIGNUM-HEADER-LENGTH M-C)
	((M-D) BIGNUM-HEADER-LENGTH M-C)
ARY-TO-BIG-CLEANUP
	((VMA-START-READ) ADD M-T A-E)
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD A-ZERO BCLEANUP)
	(JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 1) ARY-TO-BIG-CLEANUP)
       ((M-E) SUB M-E (A-CONSTANT 1))
	;; Number is nothing but sign bits
#+lambda((OA-REG-HIGH) BIGNUM-HEADER-SIGN M-C)
#+exp	((m-tem3) bignum-header-sign m-c)
#+exp	((oa-reg-high) dpb m-tem3 oah-m-src a-zero)
	((M-TEM) M-ZERO)
	((M-1) Q-POINTER M-T)				;For UN-CONS
	(JUMP-XCT-NEXT BCLEANUP-1)
       ((M-2) ADD M-D (A-CONSTANT 1))

;; Clean up and return a bignum in M-T. Hands back storage and checks for fixnums.
;; Bignum in M-T, header in M-C, length in M-D, actual length in M-E (# of non-zero words).
BCLEANUP	;must not clobber M-3
	(JUMP-GREATER-THAN M-E (A-CONSTANT 1) BCLEANUP-X)  ;Could answer be a fixnum?
	((VMA-START-READ) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-1) Q-POINTER M-T)				;For UN-CONS
	((M-2) ADD M-D (A-CONSTANT 1))
	((M-A)
	 (BYTE-FIELD (DIFFERENCE 33. Q-POINTER-WIDTH)
		     (DIFFERENCE Q-POINTER-WIDTH 1))
	 MD)			;All but 23 low bits
	(JUMP-NOT-EQUAL-XCT-NEXT M-A A-ZERO BCLEANUP-SETZP)	;no. (unless it is SETZ)
       ((M-TEM) MD)
	(JUMP-IF-BIT-CLEAR BIGNUM-HEADER-SIGN M-C BCLEANUP-1)
	((M-TEM) SUB M-ZERO A-TEM)				;Its negative.
BCLEANUP-1
	(JUMP-XCT-NEXT UN-CONS)
       ((M-T) Q-POINTER M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

BCLEANUP-SETZP
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT POSITIVE-SETZ) BCLEANUP-X)	;Is it setz?
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BCLEANUP-1)
BCLEANUP-X
	(POPJ-EQUAL M-D A-E)
	((M-2) SUB M-D A-E)			;Number of unused words at end
	((M-C) SUB M-C A-2)			;Fix the header
	((MD) ADD M-C (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-1) Q-POINTER M-T)
	(CHECK-PAGE-WRITE)
	((M-1) M+A+1 M-1 A-E)
	(JUMP UN-CONS)
))