;;; Arithmetic bugout routines for the Perq.
;;;
;;; Written by Steven Handerson, based on Milnes code.
;;; Non-numeric bugouts written by Skef Wholey.
;;;
;;; Bugout takes the function name,
;;; a switch (escapep) telling whether to insert an escape-return,
;;; a default function call (in terms of x and y),
;;; whether the function is commutative (a convenience),
;;; what types the microcode handles (chosen from (fixnum
;;; short-float long-float bignum ratio)),
;;; a list of exception pairs and code to handle them (in terms
;;; of x and y),
;;; and an optional body which gets evaluated (and should include
;;; the symbol %typecase-form).
;;;
;;; The macro generates a function containing two layers of typecase,
;;; using the floating-point contageon rules. It barfs if it discovers
;;; an uncovered case.
;;;
(eval-when (compile load eval)
(proclaim '(special %typecase-form))
)
(eval-when (compile)
(defmacro bugout (bugout-name escapep default-fn commutativep
defined-for exceptions &optional body)
(let* ((%typecase-form
`(typecase x
,@(mapcar
#'(lambda (xtype)
`(,xtype
(typecase y
,@(mapcar
#'(lambda (ytype)
`(,ytype
,(if (exception-p xtype ytype defined-for)
(find-exception xtype ytype default-fn
commutativep exceptions)
default-fn)))
'(fixnum short-float long-float bignum ratio)))))
'(fixnum short-float long-float bignum ratio)))))
`(defun ,bugout-name (x y)
(unless (numberp x)
(error "Object not number - ~A" x))
(unless (numberp y)
(error "Object not number - ~A" y))
,(if body (eval body) %typecase-form))))
(defun exception-p (xtype ytype defined-for)
(not (and (eq xtype ytype)
(member xtype defined-for))))
(defun find-exception (xtype ytype default-fn commutativep exceptions)
(cond ((eq xtype 'long-float)
(subst '(%sp-l-float y) 'y default-fn))
((eq ytype 'long-float)
(subst '(%sp-l-float x) 'x default-fn))
((eq xtype 'short-float)
(subst '(%sp-s-float y) 'y default-fn))
((eq ytype 'short-float)
(subst '(%sp-s-float x) 'x default-fn))
(t (let ((fn (assoc (list xtype ytype) exceptions :test #'equal)))
(cond ((and fn (cadr fn)) (cadr fn))
(fn default-fn)
((not commutativep) (uncovered-case-error))
((prog1 nil
(setq fn (assoc (list ytype xtype) exceptions
:test #'equal))))
((and fn (cadr fn))
(switch-subst 'x 'y (cadr fn)))
(fn default-fn)
(t (uncovered-case-error)))))))
(defun uncovered-case-error ()
(error "You lose."))
(defun switch-subst (a b list)
(let ((sym (gensym)))
(subst a sym (subst b a (subst sym b list)))))
)
;;;
;;; Arithmetic bugouts.
;;;
(defun %sp-addone-escape (x) (%sp-add-escape x 1))
(defun %sp-subtractone-escape (x) (%sp-subtract-escape x 1))
;;; Bugout for +.
(bugout %sp-add-escape T (+ x y) T (short-float long-float)
(((fixnum fixnum) (%sp-fixnum+ x y)) ;Might overflow.
((bignum bignum) (%sp-bignum+ x y))
((ratio ratio) (%sp-ratio+ x y))
((fixnum bignum) (%sp-bignum-fixnum+ y x))
((fixnum ratio) (%sp-ratio-integer+ y x))
((bignum ratio) (%sp-ratio-integer+ y x))))
(bugout %sp-subtract-escape T (- x y) nil (short-float long-float)
(((fixnum fixnum) (%sp-fixnum- x y))
((fixnum bignum) (%sp-fixnum-bignum- x y))
((fixnum ratio) (- (%sp-ratio-integer- y x)))
((bignum fixnum) (+ x (- y)))
((bignum bignum) (%sp-bignum- x y))
((bignum ratio) (- (%sp-ratio-integer- y x)))
((ratio fixnum) (%sp-ratio-integer- x y))
((ratio bignum) (%sp-ratio-integer- x y))
((ratio ratio) (%sp-ratio- x y))))
(bugout %sp-multiply-escape T (* x y) T (short-float long-float)
(((fixnum fixnum) (%sp-fixnum* x y)) ;Might overflow.
((fixnum bignum) (%sp-bignum-fixnum* y x))
((fixnum ratio) (%sp-ratio-integer* y x))
((bignum bignum) (%sp-bignum* x y))
((bignum ratio) (%sp-ratio-integer* y x))
((ratio ratio) (%sp-ratio* x y))))
(bugout %sp-divide-escape T (/ x y) nil (short-float long-float)
(((fixnum fixnum) (%sp-fixnum/ x y))
((fixnum bignum) (%sp-integer/ x y))
((fixnum ratio) (* (%sp-ratio-inverse y) x))
((bignum fixnum) (%sp-integer/ x y))
((bignum bignum) (%sp-integer/ x y))
((bignum ratio) (* (%sp-ratio-inverse y) x))
((ratio fixnum) (%sp-ratio-integer/ x y))
((ratio bignum) (%sp-ratio-integer/ x y))
((ratio ratio) (%sp-ratio/ x y)))
`(if (zerop y)
(error "/, division by zero")
,%typecase-form))
;;;
;;; Some random miscops.
;;;
(defun %sp-abs-escape (x)
(unless (numberp x)
(error "Object not number - ~A" x))
(if (minusp x) (- x) x))
;;; %sp-negate returns the negation of any integer or floating
;;; point number.
;;;
(defun %sp-negate-escape (x)
(typecase x
;; 1+ not working on the perq.
(fixnum (+ most-positive-fixnum 1))
;; if i get a fixnum, it must be from the bugout because the fixnum
;; overflows to a bignum and the only one that does this is
;; most-negative-fixnum.
(short-float (- x))
(bignum (bignum-negate x))
(long-float (- x))
(ratio (%sp-ratio-negate x))
(otherwise (error "Object not number - ~A" x))))
;;;
;;; Sfloat and Lfloat.
;;;
;;; %sp-s-float converts any number, that can be represented
;;; as an S-flonum, into an s-flonum.
;(declare (function %sp-sfloat-escape (number) short-float))
(defun %sp-sfloat-escape (X)
"%sp-sfloat-escape is an internal numeric conversion function.
%sp-s-float returns a short floating-point representation of X,
truncating towards zero."
(typecase x
(bignum
(let ((diff (- 26 (integer-length x)))) ;To be safe.
(scale-float (%sp-s-float (ash x diff)) (- diff))))
(ratio (/ (%sp-s-float (numerator x))
(%sp-s-float (denominator x))))
(otherwise
(Error "Object not number - ~A" x))))
;;; %sp-lfloat-escape converts any number into a l-flonum.
;;; VM:()
(defun %sp-lfloat-escape (X)
"%sp-lfloat-escape is an internal numeric conversion routine."
(typecase x
(bignum (%sp-lfloat-bignum x))
(ratio (let ((num (numerator x)) ;Here 'cause of bug.
(den (denominator x)))
(declare (special num den))
(/ (%sp-l-float num) (%sp-l-float den))))
(otherwise (error "Object not number - ~A" x))))
;;; Gets the b bit of integer x.
(eval-when (compile)
(defmacro get-bit (x b)
`(if (minusp ,b) 0
(cond ((fixnump ,x) (%sp-logldb 1 ,b ,x))
(t (%sp-logldb 1 (rem ,b 8)
(%primitive typed-vref 3 ,x (truncate ,b 8)))))))
)
(defun bignum-to-lfloat (big)
(let ((float (%sp-l-float 1)))
(dotimes (i 4) (%primitive long-float-set float i
(ldb (byte 16 (* 16 i)) big)))
float))
(defun lfloat-to-bignum (float)
(let ((bignum (ash 1 62)))
(dotimes (i 4) (%primitive typed-vset 4 bignum i
(%primitive long-float-ref float i)))
(integerize bignum (%sp-get-vector-length bignum))))
;;; lfloat for a bignum. *** Needs to be in ucode eventually
;;; (so we can get all the bits).
;;; Tested.
(defun %sp-lfloat-bignum (n)
(cond ((minusp n) (- (%sp-lfloat-bignum (- n))))
(t (let* ((len (integer-length n))
(diff (- 53 len))
(guard-bit (get-bit n (- -1 diff)))
(f (+ guard-bit (ash n diff)))
(carryp (if (= (integer-length f) 53) nil t))
(f (if carryp (ash f -1) f))
(e (+ len (if carryp 1023 1022))))
(cond ((> e 2046)
(error "L-float : base 2 exponent out of range - ~A" e))
(t (bignum-to-lfloat (dpb e (byte 11 52) f))))))))
;;;
;;; Predicate bugouts
;;;
;;; Comparison complement.
(defmacro comp-comp (r)
`(cond ((eq ,r '=) '=)
((eq ,r '>) '<)
(t '>)))
;(declare (function %sp-equal-escape (number number) t))
(defun %sp-equal-escape (x y)
"%sp-equal-escape is the two-argument = bugout."
(declare (type number x y))
(eq '= (compare-numbers x y)))
;(declare (function %sp-greaterthan-escape (number number) t))
(defun %sp-greaterthan-escape (x y)
"%sp-greaterthan-escape is the two argument > bugout."
(declare (type number x y))
(eq '> (compare-numbers x y)))
;(declare (function %sp-lessthan-escape (number number) t))
(defun %sp-lessthan-escape (x y)
"%sp-lessthan-escape is the two argument numeric < bugout."
(declare (type number x y))
(eq '< (compare-numbers x y)))
;;;
;;; Compare-numbers dispatches the comparison to the
;;; argument specific comparison functions.
;;;
;;; A float and an integer are equal if they are equal to the precision
;;; of the float. This is still better than just floating yourself, since
;;; we take floatability into account.
(defmacro microcode-compare (x y)
`(cond ((< ,x ,y) '<)
((> ,x ,y) '>)
(t '=)))
(bugout compare-numbers nil (microcode-compare x y) nil
(fixnum short-float long-float)
(((fixnum bignum) (comp-comp (bignum-fixnum-compare y)))
((fixnum ratio) (comp-comp (ratio-integer-compare y x)))
((bignum fixnum) (bignum-fixnum-compare x))
((bignum bignum) (bignum-compare x y))
((bignum ratio) (comp-comp (ratio-integer-compare y x)))
((ratio fixnum) (ratio-integer-compare x y))
((ratio bignum) (ratio-integer-compare x y))
((ratio ratio) (ratio-compare x y))))
;;;
;;; Truncate escape.
;;;
(defun %sp-trunc-escape-default (x y)
"This is the default escape function for truncate of two args."
(let ((q (truncate (/ x y))))
(values q (- x (* q y)))))
(bugout %sp-trunc-escape nil (%sp-trunc-escape-default x y) nil
(short-float long-float ratio)
(((fixnum fixnum) (integer-divide x y))
((fixnum bignum) (integer-divide x y))
((fixnum ratio) (%sp-trunc-escape-default x y))
((bignum fixnum) (integer-divide x y))
((bignum bignum) (integer-divide x y))
((bignum ratio) (%sp-trunc-escape-default x y))
((ratio fixnum) (%sp-trunc-escape-default x y))
((ratio bignum) (%sp-trunc-escape-default x y)))
`(cond ((= y 1)
(typecase x
(ratio (ratio-trunc x))
(fixnum (values x 0))
(bignum (values x 0))
(long-float (long-float-trunc x))
(short-float (big-short-float-trunc x))))
(t ,%typecase-form)))
(defun long-float-trunc (x)
(cond ((zerop x) (values 0 (%sp-l-float 0)))
(t (multiple-value-bind (f e s) (decode-float x)
(let ((bignum (ash 1 52)))
(dotimes (i 3)
(%primitive typed-vset 4 bignum i
(%primitive long-float-ref f i)))
(setq bignum
(dpb (%primitive long-float-ref f 3)
(byte 4 48) bignum))
(setq e (- e 53))
(let ((res1 (ash bignum e))
(res2 (if (plusp e) (%sp-l-float 0)
(scale-float
(%sp-l-float (ldb (byte (- e) 0) bignum)) e))))
(if (minusp s) (values (- res1) (- res2))
(values res1 res2))))))))
(defun big-short-float-trunc (X)
"Returns the bignum result of truncating the short float x."
(multiple-value-bind (f e s) (decode-float X)
(let ((n (ash (truncate (scale-float f 20))
(- e 20))))
(values (if (minusp s) (- n) n) 0.0s0))))
;;; Other bugout routines:
(defun %sp-assoc-escape (x l)
(do ((l l (cdr l)))
((endp l) nil)
(if (and (consp (car l))
(eql x (caar l)))
(return (car l)))))
(defun %sp-member-escape (x l)
(do ((l l (cdr l)))
((endp l) nil)
(if (eql x (car l))
(return l))))
;;; Byte-BLT passes this guy hard addresses to evil things like the middle of
;;; strings. The Source and Destination are these pointers. Byte-Count is a
;;; fixnum that is the number of bytes to move. Start bit is a fixnum that
;;; contains 1 in bit 0 if the source starts on an odd byte and a 1 in bit
;;; 16 if the destination starts on an odd byte.
(defun %sp-byte-blt-escape (source destination byte-count start-bits)
(declare (fixnum byte-count))
(let ((source-index (logand start-bits 1))
(destination-index (ash start-bits -16)))
(declare (fixnum source-index destination-index))
(cond ((< (%sp-make-fixnum source)
(%sp-make-fixnum destination))
;; Backwards if all that stuff is true.
(setq destination-index (+ destination-index byte-count))
(setq source-index (+ source-index byte-count))
(do ()
((= byte-count 0) :bugout)
(decf source-index)
(decf destination-index)
(%primitive 8bit-system-set destination destination-index
(%primitive 8bit-system-ref source source-index))
(decf byte-count)))
(t
;; Forwards elsewise.
(do ()
((= byte-count 0) :bugout)
(%primitive 8bit-system-set destination destination-index
(%primitive 8bit-system-ref source source-index))
(decf byte-count)
(incf source-index)
(incf destination-index))))))