(cond ((eql t1 0) 0)
((eql g2 1)
(%make-ratio t1 (* t2 dy)))
- (T (let* ((nn (truncate t1 g2))
+ (t (let* ((nn (truncate t1 g2))
(t3 (truncate dy g2))
(nd (if (eql t2 1) t3 (* t2 t3))))
(if (eql nd 1) nn (%make-ratio nn nd))))))))))))
"Return T if all of its arguments are numerically equal, NIL otherwise."
(the number number)
(do ((nlist more-numbers (cdr nlist)))
- ((atom nlist) T)
+ ((atom nlist) t)
(declare (list nlist))
(if (not (= (car nlist) number)) (return nil))))
((atom nlist) t)
(declare (list nlist))
(unless (do* ((nl nlist (cdr nl)))
- ((atom nl) T)
+ ((atom nl) t)
(declare (list nl))
(if (= head (car nl)) (return nil)))
(return nil))))
(declare (type real number result))
(if (< (car nlist) result) (setq result (car nlist)))))
+(defconstant most-positive-exactly-single-float-fixnum
+ (min #xffffff most-positive-fixnum))
+(defconstant most-negative-exactly-single-float-fixnum
+ (max #x-ffffff most-negative-fixnum))
+(defconstant most-positive-exactly-double-float-fixnum
+ (min #x1fffffffffffff most-positive-fixnum))
+(defconstant most-negative-exactly-double-float-fixnum
+ (max #x-1fffffffffffff most-negative-fixnum))
+
(eval-when (:compile-toplevel :execute)
;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
#!+long-float
((long-float (foreach single-float double-float))
(,op x (coerce y 'long-float)))
+ ((fixnum (foreach single-float double-float))
+ (if (float-infinity-p y)
+ ,infinite-y-finite-x
+ ;; If the fixnum has an exact float representation, do a
+ ;; float comparison. Otherwise do the slow float -> ratio
+ ;; conversion.
+ (multiple-value-bind (lo hi)
+ (case '(dispatch-type y)
+ ('single-float
+ (values most-negative-exactly-single-float-fixnum
+ most-positive-exactly-single-float-fixnum))
+ ('double-float
+ (values most-negative-exactly-double-float-fixnum
+ most-positive-exactly-double-float-fixnum)))
+ (if (<= lo y hi)
+ (,op (coerce x '(dispatch-type y)) y)
+ (,op x (rational y))))))
+ (((foreach single-float double-float) fixnum)
+ (if (eql y 0)
+ (,op x (coerce 0 '(dispatch-type x)))
+ (if (float-infinity-p x)
+ ,infinite-x-finite-y
+ ;; Likewise
+ (multiple-value-bind (lo hi)
+ (case '(dispatch-type x)
+ ('single-float
+ (values most-negative-exactly-single-float-fixnum
+ most-positive-exactly-single-float-fixnum))
+ ('double-float
+ (values most-negative-exactly-double-float-fixnum
+ most-positive-exactly-double-float-fixnum)))
+ (if (<= lo y hi)
+ (,op x (coerce y '(dispatch-type x)))
+ (,op (rational x) y))))))
(((foreach single-float double-float) double-float)
(,op (coerce x 'double-float) y))
((double-float single-float)
(defun integer-length (integer)
#!+sb-doc
- "Return the number of significant bits in the absolute value of integer."
+ "Return the number of non-sign bits in the twos-complement representation
+ of INTEGER."
(etypecase integer
(fixnum
(integer-length (truly-the fixnum integer)))
(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand newbyte mask)
(logand integer (lognot mask)))))
+
+(defun sb!c::mask-signed-field (size integer)
+ #!+sb-doc
+ "Extract SIZE lower bits from INTEGER, considering them as a
+2-complement SIZE-bits representation of a signed integer."
+ (cond ((zerop size)
+ 0)
+ ((logbitp (1- size) integer)
+ (dpb integer (byte size 0) -1))
+ (t
+ (ldb (byte size 0) integer))))
+
\f
;;;; BOOLE
(bignum (logand x ,pattern)))))
(,name ,@(loop for arg in lambda-list
collect `(prepare-argument ,arg)))))))
- (loop for infos being each hash-value of sb!c::*modular-funs*
+ (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
;; FIXME: We need to process only "toplevel" functions
when (listp infos)
do (loop for info in infos
do (forms (definition name lambda-list width pattern)))))
`(progn ,@(forms)))
+#.
+(collect ((forms))
+ (flet ((definition (name lambda-list width)
+ `(defun ,name ,lambda-list
+ (flet ((prepare-argument (x)
+ (declare (integer x))
+ (etypecase x
+ ((signed-byte ,width) x)
+ (fixnum (sb!c::mask-signed-field ,width x))
+ (bignum (sb!c::mask-signed-field ,width x)))))
+ (,name ,@(loop for arg in lambda-list
+ collect `(prepare-argument ,arg)))))))
+ (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
+ ;; FIXME: We need to process only "toplevel" functions
+ when (listp infos)
+ do (loop for info in infos
+ for name = (sb!c::modular-fun-info-name info)
+ and width = (sb!c::modular-fun-info-width info)
+ and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+ do (forms (definition name lambda-list width)))))
+ `(progn ,@(forms)))
+
;;; KLUDGE: these out-of-line definitions can't use the modular
;;; arithmetic, as that is only (currently) defined for constant
;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more
;;; discussion of this hack. -- CSR, 2003-10-09
-#!-alpha
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))
(defun sb!vm::ash-left-mod32 (integer amount)
(etypecase integer
((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
(fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
(bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
-#!+alpha
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or))
(defun sb!vm::ash-left-mod64 (integer amount)
(etypecase integer
((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
(fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
(bignum (ldb (byte 64 0)
(ash (logand integer #xffffffffffffffff) amount)))))
+
+#!+x86
+(defun sb!vm::ash-left-smod30 (integer amount)
+ (etypecase integer
+ ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
+ (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
+
+#!+x86-64
+(defun sb!vm::ash-left-smod61 (integer amount)
+ (etypecase integer
+ ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount)))
+ (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) amount)))))
projects / sbcl.git / blobdiff