;;;; files for more information.
(in-package "SB!KERNEL")
-
-(file-comment
- "$Header$")
\f
;;;; the NUMBER-DISPATCH macro
(eval-when (:compile-toplevel :load-toplevel :execute)
-;;; Grovel an individual case to NUMBER-DISPATCH, augmenting Result with the
-;;; type dispatches and bodies. Result is a tree built of alists representing
-;;; the dispatching off each arg (in order). The leaf is the body to be
-;;; executed in that case.
+;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT
+;;; with the type dispatches and bodies. Result is a tree built of
+;;; alists representing the dispatching off each arg (in order). The
+;;; leaf is the body to be executed in that case.
(defun parse-number-dispatch (vars result types var-types body)
(cond ((null vars)
(unless (null types) (error "More types than vars."))
(frob var type))
(frob var type)))))))
-;;; Our guess for the preferred order to do type tests in (cheaper and/or more
-;;; probable first.)
-;;; FIXME: not an EQL thing, should not be DEFCONSTANT
-(defconstant type-test-ordering
+;;; our guess for the preferred order in which to do type tests
+;;; (cheaper and/or more probable first.)
+(defparameter *type-test-ordering*
'(fixnum single-float double-float integer #!+long-float long-float bignum
complex ratio))
-;;; Return true if Type1 should be tested before Type2.
+;;; Should TYPE1 be tested before TYPE2?
(defun type-test-order (type1 type2)
- (let ((o1 (position type1 type-test-ordering))
- (o2 (position type2 type-test-ordering)))
+ (let ((o1 (position type1 *type-test-ordering*))
+ (o2 (position type2 *type-test-ordering*)))
(cond ((not o1) nil)
((not o2) t)
(t
(< o1 o2)))))
-;;; Return an ETYPECASE form that does the type dispatch, ordering the cases
-;;; for efficiency.
+;;; Return an ETYPECASE form that does the type dispatch, ordering the
+;;; cases for efficiency.
(defun generate-number-dispatch (vars error-tags cases)
(if vars
(let ((var (first vars))
) ; EVAL-WHEN
+;;; This is a vaguely case-like macro that does number cross-product
+;;; dispatches. The Vars are the variables we are dispatching off of.
+;;; The Type paired with each Var is used in the error message when no
+;;; case matches. Each case specifies a Type for each var, and is
+;;; executed when that signature holds. A type may be a list
+;;; (FOREACH Each-Type*), causing that case to be repeatedly
+;;; instantiated for every Each-Type. In the body of each case, any
+;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
+;;; type of that var in that instance of the case.
+;;;
+;;; As an alternate to a case spec, there may be a form whose CAR is a
+;;; symbol. In this case, we apply the CAR of the form to the CDR and
+;;; treat the result of the call as a list of cases. This process is
+;;; not applied recursively.
(defmacro number-dispatch (var-specs &body cases)
- #!+sb-doc
- "NUMBER-DISPATCH ({(Var Type)}*) {((Type*) Form*) | (Symbol Arg*)}*
- A vaguely case-like macro that does number cross-product dispatches. The
- Vars are the variables we are dispatching off of. The Type paired with each
- Var is used in the error message when no case matches. Each case specifies a
- Type for each var, and is executed when that signature holds. A type may be
- a list (FOREACH Each-Type*), causing that case to be repeatedly instantiated
- for every Each-Type. In the body of each case, any list of the form
- (DISPATCH-TYPE Var-Name) is substituted with the type of that var in that
- instance of the case.
-
- As an alternate to a case spec, there may be a form whose CAR is a symbol.
- In this case, we apply the CAR of the form to the CDR and treat the result of
- the call as a list of cases. This process is not applied recursively."
(let ((res (list nil))
(vars (mapcar #'car var-specs))
(block (gensym)))
(error 'simple-type-error :datum ,var
:expected-type ',type
:format-control
- "Argument ~A is not a ~S: ~S."
+ "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
:format-arguments
(list ',var ',type ,var))))))
\f
;;;; canonicalization utilities
-;;; If imagpart is 0, return realpart, otherwise make a complex. This is
-;;; used when we know that realpart and imagpart are the same type, but
+;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
+;;; used when we know that REALPART and IMAGPART are the same type, but
;;; rational canonicalization might still need to be done.
#!-sb-fluid (declaim (inline canonical-complex))
(defun canonical-complex (realpart imagpart)
(t
(%make-complex realpart imagpart)))))
-;;; Given a numerator and denominator with the GCD already divided out, make
-;;; a canonical rational. We make the denominator positive, and check whether
-;;; it is 1.
+;;; Given a numerator and denominator with the GCD already divided
+;;; out, make a canonical rational. We make the denominator positive,
+;;; and check whether it is 1.
#!-sb-fluid (declaim (inline build-ratio))
(defun build-ratio (num den)
(multiple-value-bind (num den)
(defun upgraded-complex-part-type (spec)
#!+sb-doc
"Returns the element type of the most specialized COMPLEX number type that
- can hold parts of type Spec."
- (cond ((subtypep spec 'single-float)
+ can hold parts of type SPEC."
+ (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 'rational)
'rational)
- (t)))
+ (t
+ 'real)))
(defun complex (realpart &optional (imagpart 0))
#!+sb-doc
(defun / (number &rest more-numbers)
#!+sb-doc
- "Divides the first arg by each of the following arguments, in turn.
- With one arg, returns reciprocal."
+ "Divide the first argument by each of the following arguments, in turn.
+ With one argument, return reciprocal."
(if more-numbers
(do ((nlist more-numbers (cdr nlist))
(result number))
(* (maybe-truncate dx g2)
(maybe-truncate dy g1))))))))
-;;; Divide two integers, producing a canonical rational. If a fixnum, we see
-;;; whether they divide evenly before trying the GCD. In the bignum case, we
-;;; don't bother, since bignum division is expensive, and the test is not very
-;;; likely to succeed.
+;;; Divide two integers, producing a canonical rational. If a fixnum,
+;;; we see whether they divide evenly before trying the GCD. In the
+;;; bignum case, we don't bother, since bignum division is expensive,
+;;; and the test is not very likely to succeed.
(defun integer-/-integer (x y)
(if (and (typep x 'fixnum) (typep y 'fixnum))
(multiple-value-bind (quo rem) (truncate x y)
(foreach single-float double-float #!+long-float long-float))
(truncate-float (dispatch-type divisor))))))
-;;; Declare these guys inline to let them get optimized a little. ROUND and
-;;; FROUND are not declared inline since they seem too obscure and too
-;;; big to inline-expand by default. Also, this gives the compiler a chance to
-;;; pick off the unary float case. Similarly, CEILING and FLOOR are only
-;;; maybe-inline for now, so that the power-of-2 CEILING and FLOOR transforms
-;;; get a chance.
+;;; Declare these guys inline to let them get optimized a little.
+;;; ROUND and FROUND are not declared inline since they seem too
+;;; obscure and too big to inline-expand by default. Also, this gives
+;;; the compiler a chance to pick off the unary float case. Similarly,
+;;; CEILING and FLOOR are only maybe-inline for now, so that the
+;;; power-of-2 CEILING and FLOOR transforms get a chance.
#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
(declaim (maybe-inline ceiling floor))
-;;; If the numbers do not divide exactly and the result of (/ number divisor)
-;;; would be negative then decrement the quotient and augment the remainder by
-;;; the divisor.
(defun floor (number &optional (divisor 1))
#!+sb-doc
"Returns the greatest integer not greater than number, or number/divisor.
The second returned value is (mod number divisor)."
+ ;; If the numbers do not divide exactly and the result of
+ ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
+ ;; and augment the remainder by the divisor.
(multiple-value-bind (tru rem) (truncate number divisor)
(if (and (not (zerop rem))
(if (minusp divisor)
(values (1- tru) (+ rem divisor))
(values tru rem))))
-;;; If the numbers do not divide exactly and the result of (/ number divisor)
-;;; would be positive then increment the quotient and decrement the remainder
-;;; by the divisor.
(defun ceiling (number &optional (divisor 1))
#!+sb-doc
"Returns the smallest integer not less than number, or number/divisor.
The second returned value is the remainder."
+ ;; If the numbers do not divide exactly and the result of
+ ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
+ ;; and decrement the remainder by the divisor.
(multiple-value-bind (tru rem) (truncate number divisor)
(if (and (not (zerop rem))
(if (minusp divisor)
(eval-when (:compile-toplevel :execute)
-(defun basic-compare (op)
+;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
+;;; to handle the case when X or Y is a floating-point infinity and
+;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec
+;;; says that comparisons are done by converting the float to a
+;;; rational when comparing with a rational, but infinities can't be
+;;; converted to a rational, so we show some initiative and do it this
+;;; way instead.)
+(defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x)
`(((fixnum fixnum) (,op x y))
((single-float single-float) (,op x y))
(((foreach single-float double-float #!+long-float long-float) rational)
(if (eql y 0)
(,op x (coerce 0 '(dispatch-type x)))
- (,op (rational x) y)))
+ (if (float-infinity-p x)
+ ,infinite-x-finite-y
+ (,op (rational x) y))))
(((foreach bignum fixnum ratio) float)
- (,op x (rational y)))))
-
-(sb!xc:defmacro two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
- `(defun ,name (x y)
- (number-dispatch ((x real) (y real))
- (basic-compare ,op)
+ (if (float-infinity-p y)
+ ,infinite-y-finite-x
+ (,op x (rational y))))))
+) ; EVAL-WHEN
- (((foreach fixnum bignum) ratio)
- (,op x (,ratio-arg2 (numerator y) (denominator y))))
- ((ratio integer)
- (,op (,ratio-arg1 (numerator x) (denominator x)) y))
- ((ratio ratio)
- (,op (* (numerator (truly-the ratio x))
- (denominator (truly-the ratio y)))
- (* (numerator (truly-the ratio y))
- (denominator (truly-the ratio x)))))
- ,@cases)))
-
-); Eval-When (Compile Eval)
-
-(two-arg-</> two-arg-< < floor ceiling
- ((fixnum bignum)
- (bignum-plus-p y))
- ((bignum fixnum)
- (not (bignum-plus-p x)))
- ((bignum bignum)
- (minusp (bignum-compare x y))))
-
-(two-arg-</> two-arg-> > ceiling floor
- ((fixnum bignum)
- (not (bignum-plus-p y)))
- ((bignum fixnum)
- (bignum-plus-p x))
- ((bignum bignum)
- (plusp (bignum-compare x y))))
+(macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
+ `(defun ,name (x y)
+ (number-dispatch ((x real) (y real))
+ (basic-compare
+ ,op
+ :infinite-x-finite-y
+ (,op x (coerce 0 '(dispatch-type x)))
+ :infinite-y-finite-x
+ (,op (coerce 0 '(dispatch-type y)) y))
+ (((foreach fixnum bignum) ratio)
+ (,op x (,ratio-arg2 (numerator y)
+ (denominator y))))
+ ((ratio integer)
+ (,op (,ratio-arg1 (numerator x)
+ (denominator x))
+ y))
+ ((ratio ratio)
+ (,op (* (numerator (truly-the ratio x))
+ (denominator (truly-the ratio y)))
+ (* (numerator (truly-the ratio y))
+ (denominator (truly-the ratio x)))))
+ ,@cases))))
+ (def-two-arg-</> two-arg-< < floor ceiling
+ ((fixnum bignum)
+ (bignum-plus-p y))
+ ((bignum fixnum)
+ (not (bignum-plus-p x)))
+ ((bignum bignum)
+ (minusp (bignum-compare x y))))
+ (def-two-arg-</> two-arg-> > ceiling floor
+ ((fixnum bignum)
+ (not (bignum-plus-p y)))
+ ((bignum fixnum)
+ (bignum-plus-p x))
+ ((bignum bignum)
+ (plusp (bignum-compare x y)))))
(defun two-arg-= (x y)
(number-dispatch ((x number) (y number))
- (basic-compare =)
-
+ (basic-compare =
+ ;; An infinite value is never equal to a finite value.
+ :infinite-x-finite-y nil
+ :infinite-y-finite-x nil)
((fixnum (or bignum ratio)) nil)
((bignum (or fixnum ratio)) nil)
"Returns the root of the nearest integer less than n which is a perfect
square."
(declare (type unsigned-byte n) (values unsigned-byte))
- ;; theoretically (> n 7), i.e., n-len-quarter > 0
+ ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
(if (and (fixnump n) (<= n 24))
(cond ((> n 15) 4)
((> n 8) 3)
projects / sbcl.git / blobdiff