X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-numbers.lisp;h=aa7304a3f94d00f7274d180d88338fc808b5e520;hb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;hp=047282d3cc0e9e2ed9448eb8ac337576c4aaa2e9;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/target-numbers.lisp b/src/code/target-numbers.lisp index 047282d..aa7304a 100644 --- a/src/code/target-numbers.lisp +++ b/src/code/target-numbers.lisp @@ -15,10 +15,10 @@ (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.")) @@ -45,24 +45,23 @@ (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)) @@ -79,21 +78,21 @@ ) ; 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))) @@ -117,7 +116,7 @@ (error 'simple-type-error :datum ,var :expected-type ',type :format-control - "Argument ~A is not a ~S: ~S." + "~@" :format-arguments (list ',var ',type ,var)))))) @@ -166,8 +165,8 @@ ;;;; 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) @@ -186,9 +185,9 @@ (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) @@ -211,8 +210,10 @@ (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) @@ -221,7 +222,8 @@ 'long-float) ((subtypep spec 'rational) 'rational) - (t))) + (t + 'real))) (defun complex (realpart &optional (imagpart 0)) #!+sb-doc @@ -339,8 +341,8 @@ (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)) @@ -458,10 +460,10 @@ (* (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) @@ -599,22 +601,22 @@ (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) @@ -623,13 +625,13 @@ (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) @@ -770,7 +772,14 @@ (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)) @@ -787,48 +796,58 @@ (((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) @@ -1275,7 +1294,7 @@ "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)