From 086927c64682b73e00cb5090ec72e1a72fb30ece Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 23 Apr 2003 17:04:52 +0000 Subject: [PATCH] 0.pre8.98: Fix for MEMBER type (as per cmucl-imp 2003-04-23) ... (MEMBER 0.0) is not the same as (SINGLE-FLOAT 0.0 0.0); ... (MEMBER 0.0 -0.0) is the same as (SINGLE-FLOAT 0.0 0.0) ... (NOT (MEMBER 0.0)) needs to be (OR (NOT SINGLE-FLOAT) (SINGLE-FLOAT * (0.0)) (MEMBER -0.0) (SINGLE-FLOAT (0.0))); ... add some tests for this one. In the process of this fix, make -0.0 and -0.0d0 dumpable by the cross-compiler: ... more special cases in src/code/cross-float.lisp. And also let an :SB-SHOW build proceed to the end ... don't try to print the slots of PCL objects. --- NEWS | 3 +++ src/code/cross-float.lisp | 52 +++++++++++++++++++++------------------- src/code/early-type.lisp | 32 +++++++++++++++++++++++++ src/code/late-type.lisp | 43 ++++++++++++++++++++++++++++----- src/code/target-defstruct.lisp | 9 +++++++ tests/type.impure.lisp | 26 ++++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 136 insertions(+), 31 deletions(-) diff --git a/NEWS b/NEWS index 7838b2e..7edf405 100644 --- a/NEWS +++ b/NEWS @@ -1668,6 +1668,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.7.14 this you were probably losing anyway. * sb-aclrepl module improvements: an integrated inspector, added repl features, and a bug fix to :trace command. + * fixed bug in MEMBER type: (MEMBER 0.0) is not the same as + (SINGLE-FLOAT 0.0 0.0), because of the existence of -0.0 which is + TYPEP the latter but not the former. * fixed some bugs revealed by Paul Dietz' test suite: ** COPY-ALIST now signals an error if its argument is a dotted list; diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp index e7236c1..72e6638 100644 --- a/src/code/cross-float.lisp +++ b/src/code/cross-float.lisp @@ -55,7 +55,7 @@ (declare (type single-float x)) (assert (= (float-radix x) 2)) (if (zerop x) - 0 ; known property of IEEE floating point: 0.0 is represented as 0. + (if (eql x 0.0f0) 0 #x-80000000) (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) (integer-decode-float x) (assert (plusp lisp-significand)) @@ -117,7 +117,7 @@ (declare (type double-float x)) (assert (= (float-radix x) 2)) (if (zerop x) - 0 ; known property of IEEE floating point: 0.0d0 is represented as 0. + (if (eql x 0.0d0) 0 #x-8000000000000000) ;; KLUDGE: As per comments in SINGLE-FLOAT-BITS, above. (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) (integer-decode-float x) @@ -177,7 +177,7 @@ (defun double-float-high-bits (x) (declare (type double-float x)) (if (zerop x) - 0 + (if (eql x 0.0d0) 0 #x-80000000) (mask-and-sign-extend (ash (double-float-bits x) -32) 32))) ;;; KLUDGE: This is a hack to work around a bug in CMU CL 18c which @@ -210,26 +210,30 @@ ;;; workarounds *do* look messy to me, which is why I just went ;;; with this quick kludge instead.) -- WHN 19990711 (defun make-single-float (bits) - (if (zerop bits) ; IEEE float special case - 0.0 - (let ((sign (ecase (ldb (byte 1 31) bits) - (0 1.0) - (1 -1.0))) - (expt (- (ldb (byte 8 23) bits) 127)) - (mant (* (logior (ldb (byte 23 0) bits) - (ash 1 23)) - (expt 0.5 23)))) - (* sign (kludge-opaque-expt 2.0 expt) mant)))) + (cond + ;; IEEE float special cases + ((zerop bits) 0.0) + ((= bits #x-80000000) -0.0) + (t (let ((sign (ecase (ldb (byte 1 31) bits) + (0 1.0) + (1 -1.0))) + (expt (- (ldb (byte 8 23) bits) 127)) + (mant (* (logior (ldb (byte 23 0) bits) + (ash 1 23)) + (expt 0.5 23)))) + (* sign (kludge-opaque-expt 2.0 expt) mant))))) (defun make-double-float (hi lo) - (if (and (zerop hi) (zerop lo)) ; IEEE float special case - 0.0d0 - (let* ((bits (logior (ash hi 32) lo)) - (sign (ecase (ldb (byte 1 63) bits) - (0 1.0d0) - (1 -1.0d0))) - (expt (- (ldb (byte 11 52) bits) 1023)) - (mant (* (logior (ldb (byte 52 0) bits) - (ash 1 52)) - (expt 0.5d0 52)))) - (* sign (kludge-opaque-expt 2.0d0 expt) mant)))) + (cond + ;; IEEE float special cases + ((and (zerop hi) (zerop lo)) 0.0d0) + ((and (= hi #x-80000000) (zerop lo)) -0.0d0) + (t (let* ((bits (logior (ash hi 32) lo)) + (sign (ecase (ldb (byte 1 63) bits) + (0 1.0d0) + (1 -1.0d0))) + (expt (- (ldb (byte 11 52) bits) 1023)) + (mant (* (logior (ldb (byte 52 0) bits) + (ash 1 52)) + (expt 0.5d0 52)))) + (* sign (kludge-opaque-expt 2.0d0 expt) mant))))) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 43394ff..b904176 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -246,9 +246,41 @@ (class-info (type-class-or-lose 'member)) (enumerable t)) (:copier nil) + (:constructor %make-member-type (members)) #-sb-xc-host (:pure nil)) ;; the things in the set, with no duplications (members nil :type list)) +(defun make-member-type (&key members) + (declare (type list members)) + ;; make sure that we've removed duplicates + (aver (= (length members) (length (remove-duplicates members)))) + ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can + ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric + ;; ranges are compared by arithmetic operators (while MEMBERship is + ;; compared by EQL). -- CSR, 2003-04-23 + (let ((singlep (subsetp '(-0.0f0 0.0f0) members)) + (doublep (subsetp '(-0.0d0 0.0d0) members)) + #!+long-float + (longp (subsetp '(-0.0l0 0.0l0) members))) + (if (or singlep doublep #!+long-float longp) + (let (union-types) + (when singlep + (push (ctype-of 0.0f0) union-types) + (setf members (set-difference members '(-0.0f0 0.0f0)))) + (when doublep + (push (ctype-of 0.0d0) union-types) + (setf members (set-difference members '(-0.0d0 0.0d0)))) + #!+long-float + (when longp + (push (ctype-of 0.0l0) union-types) + (setf members (set-difference members '(-0.0l0 0.0l0)))) + (aver (not (null union-types))) + (make-union-type t + (if (null members) + union-types + (cons (%make-member-type members) + union-types)))) + (%make-member-type members)))) ;;; A COMPOUND-TYPE is a type defined out of a set of types, the ;;; common parent of UNION-TYPE and INTERSECTION-TYPE. diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 61f6982..e4a17df 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -22,14 +22,8 @@ ;;; ### Remaining incorrectnesses: ;;; -;;; TYPE-UNION (and the OR type) doesn't properly canonicalize an -;;; exhaustive partition or coalesce contiguous ranges of numeric -;;; types. -;;; ;;; There are all sorts of nasty problems with open bounds on FLOAT ;;; types (and probably FLOAT types in general.) -;;; -;;; RATIO and BIGNUM are not recognized as numeric types. ;;; FIXME: This really should go away. Alas, it doesn't seem to be so ;;; simple to make it go away.. (See bug 123 in BUGS file.) @@ -1349,6 +1343,39 @@ (mapcar #'(lambda (x) (specifier-type `(not ,(type-specifier x)))) (union-type-types not-type)))) + ((member-type-p not-type) + (let ((members (member-type-members not-type))) + (if (some #'floatp members) + (let (floats) + (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0) + #!+long-float (0.0l0 . -0.0l0))) + (when (member (car pair) members) + (aver (not (member (cdr pair) members))) + (push (cdr pair) floats) + (setf members (remove (car pair) members))) + (when (member (cdr pair) members) + (aver (not (member (car pair) members))) + (push (car pair) floats) + (setf members (remove (cdr pair) members)))) + (apply #'type-intersection + (if (null members) + *universal-type* + (make-negation-type + :type (make-member-type :members members))) + (mapcar + (lambda (x) + (let ((type (ctype-of x))) + (type-union + (make-negation-type + :type (modified-numeric-type type + :low nil :high nil)) + (modified-numeric-type type + :low nil :high (list x)) + (make-member-type :members (list x)) + (modified-numeric-type type + :low (list x) :high nil)))) + floats))) + (make-negation-type :type not-type)))) ((and (cons-type-p not-type) (eq (cons-type-car-type not-type) *universal-type*) (eq (cons-type-cdr-type not-type) *universal-type*)) @@ -2356,6 +2383,10 @@ (let (ms numbers) (dolist (m (remove-duplicates members)) (typecase m + #!-negative-zero-is-not-zero + (float (if (zerop m) + (push m ms) + (push (ctype-of m) numbers))) (number (push (ctype-of m) numbers)) (t (push m ms)))) (apply #'type-union diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 87aab71..71c9c68 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -401,6 +401,15 @@ (let* ((layout (%instance-layout structure)) (name (classoid-name (layout-classoid layout))) (dd (layout-info layout))) + ;; KLUDGE: during the build process with SB-SHOW, we can sometimes + ;; attempt to print out a PCL object (with null LAYOUT-INFO). + #!+sb-show + (when (null dd) + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (prin1 name stream) + (write-char #\space stream) + (write-string "(no LAYOUT-INFO)")) + (return-from %default-structure-pretty-print nil)) (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") (prin1 name stream) (let ((remaining-slots (dd-slots dd))) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 2c6456d..d07044f 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -198,6 +198,32 @@ ;;; uncertainty, to wit: (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912))) '(mod 536870911))) ; aka SB-INT:INDEX. +;;; floating point types can be tricky. +(assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0))) +(assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0))) +(assert-t-t (subtypep '(member 0.0) '(single-float -0.0 0.0))) +(assert-t-t (subtypep '(member -0.0) '(single-float 0.0 -0.0))) +(assert-t-t (subtypep '(member 0.0d0) '(double-float 0.0d0 0.0d0))) +(assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 0.0d0))) +(assert-t-t (subtypep '(member 0.0d0) '(double-float -0.0d0 0.0d0))) +(assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 -0.0d0))) + +(assert-nil-t (subtypep '(single-float 0.0 0.0) '(member 0.0))) +(assert-nil-t (subtypep '(single-float 0.0 0.0) '(member -0.0))) +(assert-nil-t (subtypep '(single-float -0.0 0.0) '(member 0.0))) +(assert-nil-t (subtypep '(single-float 0.0 -0.0) '(member -0.0))) +(assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0))) +(assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member -0.0d0))) +(assert-nil-t (subtypep '(double-float -0.0d0 0.0d0) '(member 0.0d0))) +(assert-nil-t (subtypep '(double-float 0.0d0 -0.0d0) '(member -0.0d0))) + +(assert-t-t (subtypep '(member 0.0 -0.0) '(single-float 0.0 0.0))) +(assert-t-t (subtypep '(single-float 0.0 0.0) '(member 0.0 -0.0))) +(assert-t-t (subtypep '(member 0.0d0 -0.0d0) '(double-float 0.0d0 0.0d0))) +(assert-t-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0 -0.0d0))) + +(assert-t-t (subtypep '(not (single-float 0.0 0.0)) '(not (member 0.0)))) +(assert-t-t (subtypep '(not (double-float 0.0d0 0.0d0)) '(not (member 0.0d0)))) ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and diff --git a/version.lisp-expr b/version.lisp-expr index 052d9b8..d76e8b0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.97" +"0.pre8.98" -- 1.7.10.4