\f
;;;; COMPLEXes
-(defun upgraded-complex-part-type (spec &optional environment)
- #!+sb-doc
- "Return the element type of the most specialized COMPLEX number type that
- can hold parts of type SPEC."
- (declare (ignore environment))
- (cond ((unknown-type-p (specifier-type spec))
- (error "undefined type: ~S" spec))
- ((subtypep spec 'single-float)
- 'single-float)
- ((subtypep spec 'double-float)
- 'double-float)
- #!+long-float
- ((subtypep spec 'long-float)
- 'long-float)
- ((subtypep spec 'rational)
- 'rational)
- (t
- 'real)))
-
(defun complex (realpart &optional (imagpart 0))
#!+sb-doc
"Return a complex number with the specified real and imaginary components."
((complex rational)
(sb!kernel:%imagpart number))
(float
- (float 0 number))
+ (* 0 number))
(t
0)))
(multiple-value-bind (res rem) (,op number divisor)
(values (float res (if (floatp rem) rem 1.0)) rem))))
-(!define-float-rounding-function ffloor floor
- "Same as FLOOR, but returns first value as a float.")
-(!define-float-rounding-function fceiling ceiling
- "Same as CEILING, but returns first value as a float." )
-(!define-float-rounding-function ftruncate truncate
- "Same as TRUNCATE, but returns first value as a float.")
-(!define-float-rounding-function fround round
- "Same as ROUND, but returns first value as a float.")
+(defun ftruncate (number &optional (divisor 1))
+ #!+sb-doc
+ "Same as TRUNCATE, but returns first value as a float."
+ (macrolet ((ftruncate-float (rtype)
+ `(let* ((float-div (coerce divisor ',rtype))
+ (res (%unary-ftruncate (/ number float-div))))
+ (values res
+ (- number
+ (* (coerce res ',rtype) float-div))))))
+ (number-dispatch ((number real) (divisor real))
+ (((foreach fixnum bignum ratio) (or fixnum bignum ratio))
+ (multiple-value-bind (q r)
+ (truncate number divisor)
+ (values (float q) r)))
+ (((foreach single-float double-float #!+long-float long-float)
+ (or rational single-float))
+ (if (eql divisor 1)
+ (let ((res (%unary-ftruncate number)))
+ (values res (- number (coerce res '(dispatch-type number)))))
+ (ftruncate-float (dispatch-type number))))
+ #!+long-float
+ ((long-float (or single-float double-float long-float))
+ (ftruncate-float long-float))
+ #!+long-float
+ (((foreach double-float single-float) long-float)
+ (ftruncate-float long-float))
+ ((double-float (or single-float double-float))
+ (ftruncate-float double-float))
+ ((single-float double-float)
+ (ftruncate-float double-float))
+ (((foreach fixnum bignum ratio)
+ (foreach single-float double-float #!+long-float long-float))
+ (ftruncate-float (dispatch-type divisor))))))
+
+(defun ffloor (number &optional (divisor 1))
+ "Same as FLOOR, but returns first value as a float."
+ (multiple-value-bind (tru rem) (ftruncate number divisor)
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (plusp number)
+ (minusp number)))
+ (values (1- tru) (+ rem divisor))
+ (values tru rem))))
+
+(defun fceiling (number &optional (divisor 1))
+ "Same as CEILING, but returns first value as a float."
+ (multiple-value-bind (tru rem) (ftruncate number divisor)
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (minusp number)
+ (plusp number)))
+ (values (+ tru 1) (- rem divisor))
+ (values tru rem))))
+
+;;; FIXME: this probably needs treatment similar to the use of
+;;; %UNARY-FTRUNCATE for FTRUNCATE.
+(defun fround (number &optional (divisor 1))
+ "Same as ROUND, but returns first value as a float."
+ (multiple-value-bind (res rem)
+ (round number divisor)
+ (values (float res (if (floatp rem) rem 1.0)) rem)))
\f
;;;; comparisons
(defun = (number &rest more-numbers)
#!+sb-doc
"Return T if all of its arguments are numerically equal, NIL otherwise."
+ (the number number)
(do ((nlist more-numbers (cdr nlist)))
((atom nlist) T)
(declare (list nlist))
(defun /= (number &rest more-numbers)
#!+sb-doc
"Return T if no two of its arguments are numerically equal, NIL otherwise."
- (do* ((head number (car nlist))
+ (do* ((head (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun < (number &rest more-numbers)
#!+sb-doc
"Return T if its arguments are in strictly increasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ (do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun > (number &rest more-numbers)
#!+sb-doc
"Return T if its arguments are in strictly decreasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ (do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun <= (number &rest more-numbers)
#!+sb-doc
"Return T if arguments are in strictly non-decreasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ (do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun >= (number &rest more-numbers)
#!+sb-doc
"Return T if arguments are in strictly non-increasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ (do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun max (number &rest more-numbers)
#!+sb-doc
- "Return the greatest of its arguments."
+ "Return the greatest of its arguments; among EQUALP greatest, return
+the first."
(do ((nlist more-numbers (cdr nlist))
(result number))
((null nlist) (return result))
(defun min (number &rest more-numbers)
#!+sb-doc
- "Return the least of its arguments."
+ "Return the least of its arguments; among EQUALP least, return
+the first."
(do ((nlist more-numbers (cdr nlist))
(result number))
((null nlist) (return result))
#.
(collect ((forms))
(flet ((definition (name lambda-list width pattern)
- (assert (sb!xc:subtypep `(unsigned-byte ,width)
- 'bignum-element-type))
`(defun ,name ,lambda-list
(flet ((prepare-argument (x)
(declare (integer x))
(etypecase x
((unsigned-byte ,width) x)
(fixnum (logand x ,pattern))
- (bignum (logand (%bignum-ref x 0) ,pattern)))))
+ (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*
;; FIXME: We need to process only "toplevel" functions
- unless (eq infos :good)
+ 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)
for pattern = (1- (ash 1 width))
do (forms (definition name lambda-list width pattern)))))
`(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
+(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
+(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)))))
projects / sbcl.git / blobdiff