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;
(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))
(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)
(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
;;; 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)))))
(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.
;;; ### 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.)
(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*))
(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
(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)))
;;; 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))))
\f
;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
;;; 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"
projects / sbcl.git / commitdiff