4,887,235
	393	394
        funcall-funny-function-trap)
  (increment-stack-pointer)
  (function-entry-instruction-fetch (amem (xbas 1))))
	;Point frame-pointer at first argument slot in new frame
(parallel (assign frame-pointer (1+ stack-pointer))
	  (assign a-pclsr-top-of-stack (set-type (1+ stack-pointer) dtp-null))
	  (keep-function-history call))
	;Dispatch on entry instruction, maybe do seome work for callee
(dispatch-after-next (entry-instruction-dispatch memory-data)
  ((0) (next-instruction))	;Callee will do it himself
  ;here callee does not want a rest argument. So this is either too
;many arguments, or need to call a support routine to pop some
;arguments off the list, which is known not to be NIL.
;Put in b-temp the maximum number of spread arguments the callee wants.
((1) (lexpr-funcall-fast 0))
((2 3) (lexpr-funcall-fast 1))
((4 5 6) (lexpr-funcall-fast 2))
((7 10 11 12) (lexpr-funcall-fast 3))
((13 14 15 16 17) (lexpr-funcall-fast 4)))
	;Check for space in stack buffer
(parallel (trap-if (greater-pointer stack-pointer stack-limit)
		   (take-jump-trap stack-buffer-overflow-handler preserve-stack))
(take-dispatch)))

F:>lmach>ucode>FLOAT.LISP.33
;;; -*- Mode:Lisp; Package:Micro: Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.

;;;; Flonum microcode for 3600

;;; Denormalized number representation:









(define-enumerated-value-constants *flonum-operations*)


;;; Structure of "singles" flonums
;;; |1|--8---|-----23------|
;;; |S| expt | frac        |
;;;  31<30:23>---<22:0>----

(defsysbyte single-frac 23. 0)
(defsysbyte single-N-bit 1 23.)
(defsysbyte single-expt 8. 23.)
(defsysbyte single-sign 1 31.)
(defsysbyte single-except-sign 31. 0)

(eval-when (eval compile load)
(defconst single-expt-max (field-mask single-expt))
(defconst single-expt-bias 127.)
(defconst single-expt-bias-adjust 192.)
);eval-when eval compile load

;;; Structure of internal significand ("frac")
;;; ...	      -----23---- --3--
;;; ... V N . xxxxxxxxxxL G R S
;;; ...2726   --<25:3>--- 2 1 0

;;; Where V is overflow bit, N is normalized bit, L is least-significant
;;; bit of the significand, C is guard bit, R is rounding bit, and
;;; S is sticky right-shift bit.

(defsysbyte frac-S-bit 1 0)
(defsysbyte frac-grs 3 0)
(defsysbyte frac-round-dispatch 4 0)		;LGRS
(defsysbyte frac-L-bit 1 3)
(defsysbyte frac-field 23. 3)
(defsysbyte frac-field-denormalized 23. 4)	;an extra bit over, since it has no N bit
(defsysbyte frac-normalize-dispatch 4 23.)	;highest bit is N
(defsysbyte frac-N-bit 1 26.)
(defsysbyte frac-V-bit 1 27.)

;;; Some common constants, abbreviated here.
(defmacro define-side-constants (side &rest list)
  `(progn 'compile
	  ,@(loop for n in list
		  collect `(defatomicro ,(fintern "~d@~a" n side)
			     		(,(fintern "~a-CONSTANT" side) ,n)))))
(define-side-constants a 0 1 -1)
(define-side-constants b 1 2 30. 31. -1)
4,887,235
	395	396
;;;; flonum-operating-mode

(defsysbyte rounding-mode 2 1)
(def-byte-field rounding-mode-with-inexact (3 1) rounding-mode-mumble)

;;inexact-result must be to immediate left of rounding mode. See single-round-z.

(eval-when (eval compile load)

(defmacro def-rounding-mode-names (&rest pairs)
  (let* ((rm-names (loop for (name doc) in pairs
			 collect (fintern "ROUNDING-MODE-~a" name)))
	 (rm-with-inexact (append rm-names
				  (loop for name in rm-names
					collect (fintern "~a-INEXACT" name)))))
    `(progn 'compile
	    (defenumerated *rounding-mode-names* ,rm-names)
	    (defenumerated *rounding-mode-names-with-inexact* ,rm-with-inexact)
	    (defconst *flonum-rounding-mode-doc-alist*
	      ',(loop for (() doc) in pairs
		      for name in rm-names
		      collect `(,doc . ,name))))))

(def-rounding-mode-names
  (nearest "Nearest")
  (zero "toward zero")
  (plus "plus infinity")
  (minus "minus infinity")
)

(associate-dispatch-cues rounding-mode *rounding-mode-names*)
(associate-dispatch-cues rounding-mode-with-inexact *rounding-mode-names-with-inexact*)
(define-enumerated-value-constants *rounding-mode-names*)
(define-enumerated-value-constants *rounding-mode-names-with-inexact*)


(defconst *flonum-trap-names*
  '((inexact-result "Inexact Result")
    (invalid-operation "Invalid Operation")
    (overflow "Overflow")
    (underflow "Underfiow")
    (division-by-zero "Division by zero")))

(defmacro def-several-bytes (prefix collection start names)
  `(progn compile
	  ,@(loop for name in names
		  for index = start then (1+ index)
		  collect `(defsysbyte ,(fintern "~a-~a" prefix name) 1 ,index))
	  ,@(and collection
		 `((defsysbyte ,collection ,(length names) ,start)))))

(def-several-bytes trap-enable trap-enables 3
  (inexact-result invalid-operation overflow underflow division-by-zero))

(def-several-bytes flag flag-bits 8.
  (inexact-result invalid-operation overflow underflow division-by-zero))

(def-several-bytes signal () 13.
  (inexact-result invalid-operation overflow underflow division-by-zero))

(def-byte-field infinity-mode (1 18.) infinity-mode-mumble)
(defenumerated *infinity-mode-names* (infinity-mode-affine infinity-mode-projective))
(associate-dispatch-cues infinity-mode *infinity-mode-names*)
(defconst *infinity-mode-doc-alist*
  `(("Affine" . infinity-mode-affine)
    ("Projective" . infinity-mode-projective)))

;;;These forms, e.g. (flag-invalid-operation), all take 2 cycles, but they
;;;get called only in exceptional cases anyway.
#.`(progn 'compile
     ,@(loop for condition in '("INVALID-OPERATION" "OVERFLOW" "UNDERFLOW" "DIVISION-BY-ZERO")
	     as flag-name = (fintern "FLAG-~a" condition)
	     collect `(defmicro ,flag-name ()
			`(parallel
			  (assign b-temp (dpb-field lea ,',flag-name 0))
			  (call flag-flonum-operating-mode)))
	     as signal-name = (fintern "SIGNAL-~a" condition)
	     collect `(defmicro ,signal-name ()
			`(parallel
			  (assign b-temp (dpb-field lea ,',signal-name 0))
			  (call flag-flonum-operating-mode)))))

;;This uses a b-side constant because it gets called all the bloody time, and wants
;;not to take 2 cycles.
(defmicro flag-inexact-result ()
  `(assign flonum-operating-mode
	   (logior flonum-operating-mode (b-constant (field-mask flag-inexact-result)))))

(defmicro signal-inexact-result ()
  `(assign flonum-operating-mode
	   (logior flonum-operating-mode (b-constant (field-mask signal-inexact-result)))))

4,887,235
	397	398
(defmicro flag-inexact-result-and-return ()
  `(parallel
    (flag-inexact-result)
    (return)))

(defmicro signal-inexact-result-and-trap ()
  `(flonum-trap-to-macrocode (signal-inexact-result) fadd-operation))

;;;; Some general utility micros

;;This should be `(parallel (assign ,loc ,val) (if (fixnum-zero obus) ,@clauses))
;;Except that fixnuo-zero uses an alu operation.
;;Of course, we have to do it this way anyway since we can't check alu output for
;:zeroness, just for -1ness.
(defmicro if-zero-fixnum-assignment (pair &body clauses)
  (if (not (= (length pair) 2))
      (ferror () "Bad (loc val) pair in ~s"
	      `(if-zero-fixnum-assignment ,pair ,@clauses)))
  (let ((loc (first pair)) (val (second pair)))
    `(sequential
      (assign ,loc ,val)
      (if (zero-fixnum ,loc)
	  ,@clauses))))

(defmicro if-minus-fixnum-assignment (pair &body clauses)
  (if (not (= (length pair) 2))
      (ferror () "Bad (loc val) pair in ~s"
	      `(if-zero-fixnum-assignment ,pair ,@clauses)))
  (let ((loc (first pair)) (val (second pair)))
    `(parallel
      (assign ,loc ,val)
      (if (minus-fixnum obus)
	  ,@clauses))))

(defmicro ldb-regs (operand)
  `(ldb ,operand byte-s byte-r))

(defmicro flonum-trap-to-macrocode (set-condition operation)
  `(sequential
    ,set-condition
    (parallel
      (pushval (set-type ,operation dtp-fix))
      (jump push-z-and-trap-to-macrocode))))

;;; Some temporaries.

(reserve-scratchpad-memory 2413 2420)

(define-b-temps	leave-space-for-division-1
  		leave-space-for-division-2
		x-expt		;wants to be en B side because of (ldb-field next-on-stack)
		x-frac		;wants to be on B side because of (dpb-field next-on-stack)
		y-sign	 	;wants to be opposite next-on-stack.
		z-frac)		;on B because it gets replaced by byte operations on itself.

(defareg y-expt)		;wants to be on A side because of (ldb-field top-of-stack),
				;also must be on different side from x-expt.

(defareg y-frac)		;wants to be on A side because of (dpb-field top-of-stack),
				;also must be on different side from x-frac.
(defareg z-sign)		;not importantly, see pack-and-return-z
(defareg z-expt)		;probably on A because of hair in pack-and-return-z
(defareg expt-diff)

;;;; Some FADD micros
(defmicro fadd-adjust-y ()	;7 cycles
  `(sequential
     (assign z-expt x-expt)
;XXXbrad 0@a?
     (assign byte-r 0@a)
     (assign byte-s (1- expt-diff))
     (if (zero-fixnum (ldb-regs y-frac))
	 (sequential
	   (assign byte-r (- expt-diff))
	   (parallel
	     (assign byte-s (- 31@b expt-diff))
	     (if (minus-fixnum obus)
		 ;;shifting to oblivion
		 (assign y-frac 0@a)
	         (assign y-frac (ldb-regs y-frac)))))
       (sequential
	 (assign byte-r (- expt-diff))
	 (parallel
	   (assign byte-s (- 31@b expt-diff))
	   (if (minus-fixnum obus)
	       (assign y-frac (a-constant (field-mask frac-S-bit)))
	       (assign y-frac (logior (ldb-regs y-frac)
				      (b-constant (field-mask frac-S-bit))))))))))

(defmacro fadd-adjust-x-neg ()		;7 cycles
  `(sequential
    (assign z-expt y-expt)
    (assign byte-r 0@a)
    (assign byte-s (- -1@b expt-diff))
    (if (zero-fixnum (ldb-regs x-frac))
4,887,235
	399	400
    (sequential
      (assign byte-r expt-diff)
      (parallel
        (assign byte-s (+ 31@b expt-diff))
	(if (minus-fixnum obus)
	    (assign x-frac 0@a)
	  (assign x-frac (ldb-regs x-frac)))))
    (sequential
      (assign byte-r expt-diff)
      (parallel
        (assign byte-s (+ 3l@b expt-diff))
	(if (minus-fixnum obus)
	    (assign x-frac (a-constant (field-mask frac-S-bit)))
	    (assign x-frac (logior (ldb-regs x-frac)
				   (a-constant (field-mask frac-S-bit))))))))))

(defmicro right-shift-z-by-1 ()		;3 cycles
  `(sequential
    (assign z-expt (1+ z-expt))
    (if (field-bit z-frac frac-S-bit)
	(assign z-frac (logior 1@a (ldb z-frac 31. 1)))
        (assign z-frac (ldb z-frac 31. 1)))))

(defmicro pack-and-return-z ()
  `(sequential				;4 cycles
    (assign b-temp (ldb-field z-frac frac-field))
    (assign b-temp (dpb-field z-expt single-expt b-temp))
    (assign b-temp (dpb-field b-temp single-except z-sign))
    (parallel
      (pop2push (set-type b-temp dtp-float))
      (next-instruction))))

;;When z-expt <= 0, denormalize z-frac by right shifting -<z-expt> + 1 bits.
;;Costs 1 cycle in normal case.
(defmicro check-underflow (operation)
  `(if (plus-fixnum z-expt)
       (drop-through)
       (sequential
	 (if (field-bit flonum-operating-mode trap-enable-underflow)
	     (flonum-trap-to-macrocode (signal-underflow) ,operation)
	   ;;Ok, if z-expt is -n, we want to sticky-right-shift z-frac by n+1 bits.
	   (sequential
	     (flag-underflow)
	     (call normalize-z)
	     (assign byte-r 0@a)
	     (assign byte-s (- 2@b z-expt))
	     (if (zero-fixnum (ldb-regs z-frac))
		 (sequential
		   (assign byte-r (- z-expt 1@b))
		   (parallel
		    (assign byte-s (+ 30@b z-expt))
		    (if (minus-fixnum obus)
			(assign z-frac 0@a)
		        (assign z-frac (ldb-regs z-frac)))))
	       (sequential
		(assign byte-r (- z-expt 1@b))
		(parallel
		  (assign byte-s (+ 30eb z-expt))
		  (if (minus-fixnum obus)
		      (assign z-frac (a-constant (field-mask frac-S-bit)))
		      (assign z-frac (logior (ldb-regs z-frac)
					     (a-constant (field-mask frac-S-bit))))))))
	     (assign z-expt 0@a))))))

;;Invalid-Operation if storing a unnormalized (but not denorsialized) result.
;;  This is the case if N=0 and expt=0
:;Overflow if expt >= single-expt-max
;;Costs 2 cycles in the normal case.
(defmicro check-invalid-and-overflow (operation)
  `(if (field-bit z-frac frac-N-bit)
       (if (lesser-fixnum z-expt (b-constant single-expt-max))
	   (drop-through)



	   (flonum-trap-to-macrocode (signal-overflow) ,operation))
     ;;Here. we have an unnormalized fraction. It’s denormalized (and hence, Ok)
     ;;if its expt is zero.
     (if (zero-fixnum z-expt)
	 (drop-through)
;XXXbrad - just stopped - obviously something missing
)))

;;;; Flonum add/subtract
(defucode fadd
  (parallel
   (trap-no-save)
   (assign y-sign top-of-stack)
   (jump fadd-common)))

(defucode fsub
  (parallel
   (trap-no-save)
4,887,235
	401	402
   (assign y-sign (logxor -1@a top-of-stack))
   (jump fadd-common)))

(defucode fadd-common
  (if-zero-fixnum-assignment (x-expt (ldb-field next-on-stack single-expt))
    (assign x-frac (dpb-field next-on-stack frac-field-denormalized 0))
    (if (equal-fixnum x-expt (a-constant single-expt-max))
	(goto fadd-inf-or-nan)
        (assign x-frac (+ (b-constant (field-mask frac-N-bit))
			  (dpb-field next-on-stack frac-field 0)))))
	(if-zero-fixnum-assignment (y-expt (ldb-field top-of-stack single-expt))
;XXXbrad B?
	  (assign y-frac (dpb-field top-of-stack frac-field-denormalized B))
	  (if (equal-fixnum y-expt (b-constant single-expt-max))
	      (goto fadd-to-inf-or-nan)
	      (sequential
	        (assign b-temp (dpb-field top-of-stack frac-field
					  (a-constant (field-mask frac-N-bit))))
		(assign y-frac b-temp))))
	;;Adjust
	(if-zero-fixnum-assignment (expt-diff (- x-expt y-expt))
	  (assign z-expt x-expt)
	  (if (minus-fixnum expt-diff)
	      (fadd-adjust-x-neg)
	      (fadd-adjust-y)))
	;;Check signs
	(if (not (minus-fixnum (logxor y-sign next-on-stack)))
	    ;;signs the same, add magnitudes
	    (sequential
	     (assign z-sign y-sign)
	     (assign z-frac (+ x-frac y-frac))
	     (if (field-bit z-frac frac-V-bit)
		 (right-shift-z-by-1)
	         (if (zero-fixnum z-frac)
		     (goto fadd-resulted-in-zero)
		     (drop-through))))
	  ;;signs differ, subtract magnitudes
	  (sequential
	    (if (plus-or-zero-fixnum y-sign)
		(assign z-frac (- y-frac x-frac))
	        (assign z-frac (- x-frac y-frac)))
	    (if (zero-fixnum z-frac)
		(goto fadd-resulted-in-zero)		;check for true zero vs. underflow
	        (if (minus-fixnum z-frac)	
		    (sequential
		      (assign z-frac (- z-frac))
		      (assign 2-sign (a-constant (field-mask single-sign))))
		    (assign z-sign 0@a)))
	    ;;Check whether input operands had been normalized
	    (assign b-temp (logior x-frac y-frac))
	    (if (field-bit b-temp frac-N-bit)
		(call normalize-z)
	        (drop-through))))
	(check-underflow fadd-operation)
	(call single-round-z)
	(check-invalid-and-overflow fadd-operation)
	(pack-and-return-z))

;;;; Normalization
;;; Shift up to 4 bits at a whack. We try to pipeline something useful
;;; with take-dispatch, hence some of the hair here. Below, * represents
;;;a microcycle. (xxx;yyy) represents xxx and yyy done in parallel.

;;; Main				Aux
;;; * Select dispatch			* Select dispatch
;;; * Take dispatch			* (Assign expt; Take dispatch, same as at left)
;;;   0:	* (assign frac; jump aux)
;;;   1-7:	* Assign frac
;;;		* (Assign expt; return)
;;; 8-15:	* Return

;;; We parallel


(defmicro z-normalize-steps (num)
  `(sequential
     (assign z-frac (rotate a-frac ,num))
     (assign z-expt (- z-expt (b-constant ,num)))))

;; This is a micro so it can be shared between normalize-z and normalize-z-aux
;; next is the "next" that follows dispatch-after-next
(defmicro normalize-z-dispatch (next)
  `(parallel
     (dispatch-after-next (ldb-field z-frac frac-normalize-dispatch)
      ;;Dispatching on N.xxx
      ((0)		;0000
        (parallel
	  (assign z-frac (rotate a-frac 4))
	  (jump normalize-z-aux)))
      ((1)		;0001
       (parallel
	(z-normalize-steps 3)
	(return)))
4,887,235
	403	404
      ((2 3)		;001x
       (parallel
	(z-normalize-steps 2)
	(return)))
      ((4 5 6 7)	;01xx
       (parallel
	(z-normalize-steps 1)
	(return))))
     (if (greater-or-equal-fixnum-unsigned (ldb-field z-frac frac-normalize-dispatch)
					   (a-constant #o10))
	 (parallel ,next (return))
         (parallel ,next (take-dispatch)))))

(defucode normalize-z
  (normalize-c-dispatch ()))

(defucode normalize-z-aux
  (normalize-z-dispatch
   (assign z-expt (- z-expt (b-constant 4)))))

;;;; Rounding

(defmicro increment-z-frac-L-bit ()
  `(sequential
    (assign z-frac (+ z-frac (a-constant (field-mask frac-L-bit))))
    (if (field-bit z-frac frac-V-bit)
	(right-shift-z-by-1)
      (drop-through))))

;;We dispatch on rounding mode combined uith the inexact-result-trap-enable bit,
;;so we ocn’t have to screw around deciding whether to trap.

(defucode single-round-z
  (if (equal-fixnum (rounding-mode-with-inexact flonum-operating-mode)
		    rounding-mode-nearest)
	;;r-ound z to nearest don’t try to trap on Inexact-Result
	;;We can’t pull the IF/DISPATCH hack here because z-frac comes from B side
	;;as must the internally-genorated constant for (if (zero-fixnum alub) ...)
      (dispatch-after-this (ldb-field z-frac frac-round-dispatch)
			   (nop)
	;; dispatching on LGRS: Sianal Inexact-Result unless CRS=0,
        ;; do nothing further when GRS < 4. When GPS=4 make the L bit zero
	;; (i.e., 0100 ok, 1100 add 1 in L position). Otherwise, add 1 in L.
	((0 10) ;0000, 1000
	 (return))
	((1 2 3 4 #o11 #o12 #o13)	;0001, 001x,d. 0100, 1001, 101x
	 (flag-inexact-result-and-return))
	((5 6 7 14 15 16 17)		;01xx, 11xx
	 (increment-z-frac-L-bit)
	 (flag-inexact-result-and-return)))
    (drop-through))
  (dispatch-after-this (rounding-mode-with-inexact flonum-operating-mode)
		       (nop)
    ;;rounding-mode-nearest is taken care of by the IF above
    ((rounding-mode-nearest-inexact) ;do trap on inexact result
     (dispatch-after-this (ldb-field z-frac frac-round-dispatch)
			  (nop)
       ((0 10)	;0000, 1000
	(return))
       ((1 2 3 4 #011 #o12 #o13)	;0001, 001x, 0100, 1001. 101x
	(signal-inexact-result-and-trap))
       ((5 6 7 14 15 16 17)	;Olxx, llxx
	(increment-z-frac-L-bit)
	(signal-inexact-result-and-trap))))
    ((rounding-mode-zero)
     (if (not-zero-fixnum (ldb-field z-frac frac-gre))
	 (flag-inexact-result-and-return)
       (return)))
    ((rounding-mode-zero-inexact)
     (if (not-zero-fixnum (ldb-field z-frac frac-grs))
	 (signal-inexact-result-and-trap)
       (relurn)))
    ((rounding-mode-plus)
     (if (plus-fixnum z-sign)
	 (goto single-round-z-up-nosignal)
         (goto single-round-z-down-nosignal)))
    ((rounding-mode-plus-inexact)
     (if (plus-fixnum z-sign)
	 (goto single-round-z-up-signal)
         (goto single-round-z-down-signal)))
    ((rounding-mode-minus)
     (if (plus-fixnum z-sign)
	 (goto single-round-z-down-nosignal)
         (goto single-round-z-up-nosignal)))
    ((rounding-mode-minus-inexact)
     (if (plus-fixnum z-sign)
	 (goto single-round-z-down-signal)
         (goto single-round-z-up-signal)))))

(defucode single-round-z-up-nosignal
  (if (zero-fixnum (ldb-field z-frac frac-grs))
      (return)
4,887,235
	405	406
	(sequential
	 (increment-z-frac-L-bit)
	 (flag-inexact-result-and-return))))

(defucode single-round-z-up-signal
  (if (zero-fixnum (ldb-field z-frac frac-grs))
      (return)
    (sequential
     (increment-z-frac-L-bit)
     (signal-inexact-result-and-trap))))

(defucode single-round-z-down-nosignal
  (if (zero-fixnum (ldb-field z-frac frac-grs))
      (flag-inexact-result-and-return) 
    (return)))

(defucode single-round-z-down-signal
  (if (zero-fixnum (ldb-field z-frac frac-grs))
      (signal-inexact-result-and-trap)
    (return)))

;;;; fadd exceptional oases
;;Might as well save a ucode space word everywhere, as well.
(defucode flag-flonum-operating-mode
  (parallel
   (assign flonum-operating-mode
	   (logior flonum-operating-mode b-temp))
   (return)))

(defucode fadd-resulted-in-zero
  (if (equal-fixnum (ldb-field flonum-operating-mode rounding-mode)
		    rounding-made-minus)
      (assign z-sign (a-constant (field-mask single-sign)))
      (assign z-sign 0@a))
  ;;If either operand was normalized after binary point alignment, set the exponent
  ;;to minimum value, i.e., true zero. If neither was, leave the expt alone, so
  ;;an Underflow trap will occur when storing the result is attempted.
  (assign b-temp (logior x-frac y-frac))
  (if (field-bit b-temp frac-N-bit)
     (parallel
       (pop2push (set-type z-sign dtp-float))
       (next-instruction))
     (if (zero-fixnum b-temp)			;both operands were zero
	 (parallel
	   (pop2push (set-type z-sign dtp-float))
	   (next-instruction))
         (flonum-trap-to-macrocode (signal-underflow) fadd-operation))))

(defucode push-z-and-trap-to-macrocode
  (pushval (set-type z-frac dtp-fix))
  (pushval (set-type z-expt dtp-fix))
  (pushval (set-type z-sign dtp-fix))
  (jump trap-to-macrocode))

(defucode fadd-inf-or-nan
  (flonum-trap-to-macrocode (signal-invalid-operation) fadd-operation))

(defucode fadd-to-inf-or-nan
  (flonum-trap-to-macrocode (signal-invalid-operation) fadd-operation))

(defucode trap-to-macrocode		;--- someone should write this
  (signal-error-no-restore-stack floating-point-trap-to-macrocode))

;;; Scaling

;If there is any exception, we just trap to the macrocoded ash, which is perhaps wrong
(defucode ash-float
  ;; First check for exceptional cases
  (if (zero-fixnum (ldb-field next-on-stack single-except-sign))	;0.0 or -0.0
      (parallel
       (pop2push next-on-stack)
       (next-instruction))
     (drop-through))
  (if (zero-fixnum (ldb-field next-on-stack single-expt))
      (goto ash-overflow)
      (drop-through))
  (if (equal-fixnum (ldb-field next-on-stack single-expt) (b-constant single-expt-max))
      (goto ash-overflow)
      (drop-through))
  ;; Scale the exponent
  (assign b-temp (+ (ldb-field next-on-stack single-expt) top-of-stack))
  (if (plus-fixnum b-temp)
      (if (lesser-fixnum b-temp (a-constant single-expt-max))
	  (parallel
	   (pop2push (set-type (dpb-field b-temp single-expt next-on-stack) dtp-float))
	   (next-instruction))
	(goto ash-overflow))		;expanent overflow
    (goto ash-overflow)))		;exponent under-flow

;	  5         4         3         2         1         0
;      321.987654321.98765432|1.987654321.987654321.987654321.
;	n....................|...grsn.......................grx	  without V
;	654321.987654321.9876|54321.
;	.987654321.987654321.|
4,887,235
	407	408
;	n.....................|..grsn.......................grs   with V
;	654321.987654321.98765|4321.
;	1.987654321.987654321.|
;	321.987654321.98765432|1.987664321.987654321.987654321.
;	   5         4         3         2         1         0

(defsysbyte fmul-lo-lost 26. 0)
(defsysbyte fmul-lo-take 6 26.)
(defsysbyte fmul-hi-take 21. 0)
(defsysbyte fmul-hi-put 21. 6)
(defsysbyte fmul-hi-V-bit 1 21.)

(defsysbyte fmul-lo-lost-V 27. 0)
(defsysbyte fmul-lo-take-V 5. 27.)
(defsysbyte fmul-hi-take-V 22. 0)
(defsysbyte fmul-hi-put-V 22. 5)

(defatomicro fmul-hi-part expt-diff)
(defatomicro fmul-lo-part b-low-dividend)

;;to pass to mpy-32-32 which wants routines
(defmicro fmul-store-hi-part (x)
  `(assign fmul-hi-part ,x))
(defmicro fmul-store-lo-part (x)
  `(assign fmul-lo-part ,x))

(defucode fmul
  (parallel (if-zero-fixnum-assignment (x-expt (ldb-field next-on-stack single-expt))
	       (assign x-frac (dpb-field next-on-stack frac-field-denormalized 0))
	       (if (equal-fixnum x-expt (a-constant single-expt-max))
		   (gato fmul-inf-or-nan)
		   (assign x-frac (+ (b-constant (field-mask frac-N-bit))
				     (dpb-field next-on-stack frac-field B)))))
	    (trap-no-save))
  (if-zero-fixnum-assignment (y-expt (ldb-field top-of-stack single-expt))
    (assign y-frac (dpb-field top-of-stack frac-field-denormalized 0))
    (if (equal-fixnum y-expt (b-constant single-expt-max))
	(goto fmul-to-inf-or-nan)
      (sequential
        (assign b-temp (dpb-field top-of-stack frac-field
				  (a-constant (field-mask frac-N-bit))))
	(assign y-frac b-temp))))
  (assign z-sign (logxor top-of-stack next-on-stack))
  (mpy-32-32 y-frac x-frac
	     fmul-store-lo-part fmul-store-hi-part
	     ())
  (if (field-bit fmul-hi-part fmul-hi-V-bit)
      (sequential
       (assign z-expt (+ x-expt y-expt 1))
       (if (zero-fixnum (ldb-field fmul-lo-part fmul-lo-lost-V))
	   (assign z-frac (ldb-field fmul-lo-part fmul-lo-take-V))
	 (assign z-frac (logior 1@a (ldb-field fmul-lo-part fmul-lo-take-V))))
         (assign z-frac (dpb-field fmul-hi-part fmul-hi-put-V z-frac)))
    (sequential
     (assign z-expt (+ x-expt y-expt))
     (if (zero-fixnum (ldb-field fmul-lo-part fmul-lo-lost))
	 (assign z-frac (ldb-field fmul-lo-part fmul-lo-take))
         (assign z-frac (logior 1@a (ldb-field fmul-lo-part fmul-lo-take))))
     (assign z-frac (dpb-field fmul-hi-part fmul-hi-put z-frac))))
  (if (not-zero-fixnum z-frac)
      (sequential
       (assign z-expt (- z-expt (b-constant single-expt-bias)))
       (check-underflow fmul-operation))
    (assign c-expt 0@a))
  (call single-round-z)
  (check-invalid-and-overflow fmul-operation)
  (pack-and-return-z))

(defucode fmul-inf-or-nan
  (flonum-trap-to-macrocode (signal-invalid-operation) fmul-operation))
(defucode fmul-to-inf-or-nan
  (flonum-trap-to-macrocode (signal-invalid-operation) fmul-operation))

;;divisar is top-of-stack (b) moved to y
;;dividend is next-on-stack (a) moved to x

;	   5         4         3         2         1         0
;	321.987654321.98765432|1.987654321.987654321.987654321.
;	    n.................|.....|grs?......................|   ;dividend, upper
;	    321.987654321.9876|54321.
;	    7654321.987654321.|
;	                      |        n.......................|   ;divisor
;	321.987654321.98765432|1.987654321.987654321.987654321.
;	   5         4         3         2         1         0

(defsysbyte fdiv-hi-take 17. 6)		;dividend
(defsysbyte fdiv-lo-put 6 26.)
(eval-when (eval compile load)
(defconst fdiv-hi-N-bit (ash 1 17.))
)
4,887,235
	409	410

(defucode fdiv
  ;;hack the divisor
  (parallel
    (if-zero-fixnum-assignment (y-expt (ldb-field top-of-stack single-expt))
       (goto fdiv-by-zero-or-denorm)
       (if (equal-fixnum y-expt (b-constant single-expt-max))
	   (goto fdiv-by-inf-or-nan)
	 (sequential
	   (assign a-positive-divisor (ldb-field top-of-stack single-frac))
	   (assign a-positive-divisor
		   (logior a-positive-divisor (b-constant (field-mask single-N-bit))))
	   (assign a-negative-divisor (- a-positive-divisor)))))
    (trap-no-save))
  ;;hack the dvidend
  (if-zero-fixnum-assignment (x-expt (ldb-field next-on-stack single-expt))
    ;; Divisor is normal, but dividend is zero or denormaliced
    (if (zero-fixnum (ldb-field next-on-stack single-frac))
	;; Zero divided by non-zero is zero, with xor- of opcr-and& signo
	(sequential
	  (assign b-temp (dpb-field (b-constant 0) single-except-sign top-of-stack-a))
	  (parallel (pop2push (set-type (logxor next-on-stack b-temp) dtp-float))
		    (next-instruction)))
      ;; Dividend is denormalized
      (goto fdiv-into-denorm))
    ;; Dividend and divisor are normal
    (if (equal-fixnum x-expt (a-constant single-expt-max))
	(goto fdiv-into-inf-or-nan)
      (sequential
       (assign b-high-dividend
	       (logior (ldb-field next-on-stack fdiv-hi-take)
		       (b-constant fdiv-hi-N-bit)))
       (assign b-low-dividend (dpb-field next-on-stack fdiv-lo-put 8)))))
  (parallel
   ;;15. - 32./2-1. see call to divide-routine in the DIVISION file.
   ;;consider shifting operands to reduce this to 24./2-1 somehow.
   (assign a-divide-step-count (a-constant 15.))
   (call divide-subroutine)) ;leave quo in b-tow-dividend, and rem in b-high-dividend.
  ;;if there was a remainder, set the sticky bit for rounding; and move to z-frac for
  ;;single-round-z.
  ;;--- figure a good way to fold this in with the rounding??
  (if (not-zero-fixnum b-high-dividend)
      (assign z-frac (logior b-low-dividend (a-constant (field-mask frac-S-bit))))
      (assign z-frac b-low-dividend))
  ;;If quotient N-bit is zero, then left-shift quo by 1 and decr its expt
  (if (field-bit b-low-dividend frac-N-bit)
      (assign z-expt (- x-expt y-expt))
    (sequential
     (assign z-expt (- x-expt y-expt 1))
     (assign z-frac (rotate z-frac 1))))
  (assign z-expt (+ z-expt (b-constant single-expt-bias)))
  (assign z-sign (logxor next-on-stack top-of-stack))
  (check-underflow fdiv-operation)
  (call single-round-z)
  (check-invalid-and-overflow fdiv-operation)
  (pack-and-return-z))

(defucode fdiv-by-zero-or-denorm
  (flonum-trap-to-macrocode (signal-invalid-operation) fdiv-operation))
(defucode fdiv-by-inf-or-nan
  (flonum-trap-to-macrocode (signal-invalid-operation) fdiv-operation))
(defucode fdiv-into-denorm
  (flonum-trap-to-macrocode (signal-invalid-operation) fdiv-operation))
(defucode fdiv-into-inf-or-nan
  (flonum-trap-to-macrocode (signal-invalid-operation) fdiv-operation))

;;; Convert fixnum on top of stack to flonum on top of stack
;;;Traps to macrocode arent really going to work, yet.

(eval-when (eval compile load)
(defconst *setz-as-flonum*		;setz here being -1_31.
  (dpb-field 1 single-sign
	     (dpb-field (+ single-expt-bias 31.) single-expt 0)))
);eval-when eval-compile-load

(defucode convert-fixnum-to-flonum
  (if (minus-fixnum top-of-stack)
      (if (zero-fixnum (ldb top-of-stack 31. 0))	;setz?
	  (parallel
	   (newtop (set-type (b-constant *setz-as-flonum*) dtp-float))
	   (return))
	(sequential
	 (assign z-sign (b-constant 1_31.))
	 (assign b-temp (- top-of-stack))))
    (if (zero-fixnum top-of-stack)
	(parallel
	 (newtop (set-type (b-constant 0) dtp-float))
	 (return))
      (sequential
       (assign z-sign (b-constant 0))
       (assign b-temp top-of-stack))))
  (if (zero-fixnum (ldb b-temp 4 27.))		;the bits above frac-n-bit
4,887,235
	411	412
      ;;they are zero, no sweat
      (sequential
       (assign z-expt (b-constant (+ single-expt-bias 26.))) ;26. is how far to shift 1 -> N
       (assign z-frac b-temp))
      ;;same bits up there, need to shift right by 4 to clear then
      (sequential
       (assign z-expt (b-constant (+ single-expt-bias 26. 4))) ;yes
       (if (zero-fixnum (ldb b-temp 4 0))	;is sticky bit adjustment necessary?
	   (assign z-frac (ldb b-temp 28. 4))	;no
	   (assign z-frac (logior (ldb b-temp 28. 4) (a-constant 1))))))
  (call normalize-z)		;bum a couple cycles here somehow?
  (call single-round-z)
  (assign b-temp (ldb-field z-frac frac-field))
  (assign b-temp (dpb-field z-expt single-expt b-temp))
  (assign b-temp (dpb-field b-temp single-except-sign z-sign))
  (parallel
   (newtop (set-type b-temp dtp-float))
   (return)))

;;; Compare flonums: Returns positive number if the first is greater- than the second
;;; neqative number if the second is greater than the first, and 0 if they are equal
(defucode flonum-compare
  (if (zero-fixnum (ldb-field next-on-stack single-expt))
      (assign x-frac (dpb-field next-on-stack single-frac 0))
      (assign x-frac next-on-stack))
  (if (zero-fixnum (ldb-field top-of-stack-a single-expt))
      (assign y-frac (dpb-field top-of-stack-a single-frac 0))
      (assign y-frac top-of-stack-a))
  (if (equal-fixnum (ldb-field next-on-stack single-expt) (b-constant single-expt-max))
      (goto compare-first-inf-or-nan)
    (drop-through))
  (if (equal-fixnum (ldb-field top-of-stack-a single-expt) (b-constant single-expt-max))
      (goto compare-second-inf-or-nan)
    (drop-through))
  ;; This crap is because of signed magnitude lossage
  (if (minus-fixnum x-frac)
      (if (minus-fixnum y-frac)
	  ;; Both negative, larger if xfrac < y-frac
	  (parallel (pop2push (set-type (- y-frac x-frac) dtp-fix))
		    (return))
	  ;; First is neoative, second is positive
	  (parallel (pop2push (set-type (b-constant -1) dtp-fix))
		    (return)))
      (if (minus-fixnum y-frac)
	  ;; First is positive, second is negative
	  (parallel (pop2push (set-type (b-constant 1) dtp-fix))
		    (return))
	  ;; Both positive la.r-oer- if x-frac > y-frac
	  (parallel (pop2push (set-type (- x-frac y-frac) dtp-fix))
		    (return)))))

(defucode fgreaterp
  (parallel (nop) (trap-no-save))	;Cannot call in first cycle after trap
  (call flonum-compare)
  (if (plus-fixnum top-of-stack-a)
      (goto true1)
      (goto false1)))

(defucode flessp
  (parallel (nop) (trap-no-save))	;Cannot call in first cycle after trap
  (call flonum-compare)
  (if (minus-fixnum top-of-stack-a)
      (goto true1)
      (goto false1)))

(defucode fequal
  (parallel (nop) (trap-no-save))	;Cannot call in fir-st cycle after- trap
  (call flonum-compare)
  (if (zero-fixnum top-of-stack-a)
      (goto true1)
      (goto false1)))

;;; Signum of flonums:
;;; (This is not the SIGNUM function, since it returns a fixnum, not a flonum)
(defucode fsignum
  (if (zero-fixnum (ldb-field top-of-stack-a signal-except-sign))
      (parallel (newtop (set-type (b-constant 0) dtp-fix))
		(return))
    (drop-through))
  (if (equal-fixnum (ldb-field top-of-stack-a single-expt) (b-constant single-expt-max))
      (goto signum-inf-or-nan)
      (drop-through))
  (if (minus-fixnum top-of-stack-a)
      (parallel (newtop (set-type (b-constant -1) dtp-fix))
		(return))
      (parallel (newtop (set-type (b-constant 1) dtp-fix))
		(return))))

;;; These could be bummed one cycle if fsignum was not signum, but just returned
;;; the argument except with zero
(defucode fplusp
