;; for e.g. DESCRIPTOR-REG, needed by primtype.lisp
("src/compiler/target/vm")
-
+ ("src/code/xset")
;; for e.g. SPECIFIER-TYPE, needed by primtype.lisp
("src/code/early-type")
:export (;; lambda list keyword extensions
"&MORE"
+ ;; utilities for floating point zero handling
+ "FP-ZERO-P"
+ "NEG-FP-ZERO"
+
+ ;; generic set implementation
+ "ADD-TO-XSET"
+ "ALLOC-XSET"
+ "MAP-XSET"
+ "XSET"
+ "XSET-COUNT"
+ "XSET-EMPTY-P"
+ "XSET-INTERSECTION"
+ "XSET-MEMBER-P"
+ "XSET-MEMBERS"
+ "XSET-SUBSET-P"
+ "XSET-UNION"
+
;; communication between the runtime and Lisp
"*CORE-STRING*"
"MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
"MAKE-UNPORTABLE-FLOAT" "%MAKE-INSTANCE"
"MAKE-SHORT-VALUES-TYPE" "MAKE-SINGLE-VALUE-TYPE"
- "MAKE-VALUE-CELL" "MAKE-VALUES-TYPE" "MEMBER-TYPE"
- "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" "MERGE-BITS"
+ "MAKE-VALUE-CELL" "MAKE-VALUES-TYPE"
+ "MAPC-MEMBER-TYPE-MEMBERS" "MAPCAR-MEMBER-TYPE-MEMBERS"
+ "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P"
+ "MEMBER-TYPE-SIZE" "MERGE-BITS"
"MODIFIED-NUMERIC-TYPE" "MUTATOR-SELF" "NAMED-TYPE"
"NAMED-TYPE-NAME" "NAMED-TYPE-P" "NATIVE-BYTE-ORDER"
"NEGATE" "NEGATION-TYPE" "NEGATION-TYPE-TYPE"
;; call TYPE=, that in turn may call CTYPEP). Until then, pick a few
;; cherries off.
(cond ((member-type-p ctype)
- (if (member obj (member-type-members ctype))
+ (if (member-type-member-p obj ctype)
(values t t)
(values nil t)))
((union-type-p ctype)
bindings)))
,@forms)))
+(in-package "SB!KERNEL")
+
+(defun fp-zero-p (x)
+ (typecase x
+ (single-float (zerop x))
+ (double-float (zerop x))
+ #!+long-float
+ (long-float (zerop x))
+ (t nil)))
+
+(defun neg-fp-zero (x)
+ (etypecase x
+ (single-float
+ (if (eql x 0.0f0)
+ (make-unportable-float :single-float-negative-zero)
+ 0.0f0))
+ (double-float
+ (if (eql x 0.0d0)
+ (make-unportable-float :double-float-negative-zero)
+ 0.0d0))
+ #!+long-float
+ (long-float
+ (if (eql x 0.0l0)
+ (make-unportable-float :long-float-negative-zero)
+ 0.0l0))))
(class-info (type-class-or-lose 'member))
(enumerable t))
(:copier nil)
- (:constructor %make-member-type (members))
+ (:constructor %make-member-type (xset fp-zeroes))
#-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))
+ (xset (missing-arg) :type xset)
+ (fp-zeroes (missing-arg) :type list))
+(defun make-member-type (&key xset fp-zeroes members)
+ (unless xset
+ (aver (not fp-zeroes))
+ (setf xset (alloc-xset))
+ (dolist (elt members)
+ (if (fp-zero-p elt)
+ (pushnew elt fp-zeroes)
+ (add-to-xset elt xset))))
;; 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 ((n-single (load-time-value
- (make-unportable-float :single-float-negative-zero)))
- (n-double (load-time-value
- (make-unportable-float :double-float-negative-zero)))
- #!+long-float
- (n-long (load-time-value
- (make-unportable-float :long-float-negative-zero)))
- (singles nil)
- (doubles nil)
- #!+long-float
- (longs nil))
- ;; Just a single traversal, please! MEMBERS2 starts as with MEMBERS,
- ;; sans any zeroes -- if there are any paired zeroes then the
- ;; unpaired ones are added back to it.
- (let (members2)
- (dolist (elt members)
- (if (and (numberp elt) (zerop elt))
- (typecase elt
- (single-float (push elt singles))
- (double-float (push elt doubles))
- #!+long-float
- (long-float (push elt longs)))
- (push elt members2)))
- (let ((singlep (and (member 0.0f0 singles)
- (member n-single singles)
- (or (aver (= 2 (length singles))) t)))
- (doublep (and (member 0.0d0 doubles)
- (member n-double doubles)
- (or (aver (= 2 (length doubles))) t)))
- #!+long-float
- (longp (and (member 0.0l0 longs)
- (member n-long longs)
- (or (aver (= 2 (lenght longs))) t))))
- (if (or singlep doublep #!+long-float longp)
- (let (union-types)
- (if singlep
- (push (ctype-of 0.0f0) union-types)
- (setf members2 (nconc singles members2)))
- (if doublep
- (push (ctype-of 0.0d0) union-types)
- (setf members2 (nconc doubles members2)))
- #!+long-float
- (if longp
- (push (ctype-of 0.0l0) union-types)
- (setf members2 (nconc longs members2)))
- (aver (not (null union-types)))
- (make-union-type t
- (if (null members2)
- union-types
- (cons (%make-member-type members2)
- union-types))))
- (%make-member-type members))))))
+ (let ((unpaired nil)
+ (union-types nil))
+ (do ((tail (cdr fp-zeroes) (cdr tail))
+ (zero (car fp-zeroes) (car tail)))
+ ((not zero))
+ (macrolet ((frob (c)
+ `(let ((neg (neg-fp-zero zero)))
+ (if (member neg tail)
+ (push (ctype-of ,c) union-types)
+ (push zero unpaired)))))
+ (etypecase zero
+ (single-float (frob 0.0f0))
+ (double-float (frob 0.0d0))
+ #!+long-float
+ (long-float (frob 0.0l0)))))
+ ;; The actual member-type contains the XSET (with no FP zeroes),
+ ;; and a list of unpaired zeroes.
+ (let ((member-type (unless (and (xset-empty-p xset) (not unpaired))
+ (%make-member-type xset unpaired))))
+ (cond (union-types
+ (make-union-type t (if member-type
+ (cons member-type union-types)
+ union-types)))
+ (member-type
+ member-type)
+ (t
+ *empty-type*)))))
+
+(defun member-type-size (type)
+ (+ (length (member-type-fp-zeroes type))
+ (xset-count (member-type-xset type))))
+
+(defun member-type-member-p (x type)
+ (if (fp-zero-p x)
+ (and (member x (member-type-fp-zeroes type)) t)
+ (xset-member-p x (member-type-xset type))))
+
+(defun mapcar-member-type-members (function type)
+ (declare (function function))
+ (collect ((results))
+ (map-xset (lambda (x)
+ (results (funcall function x)))
+ (member-type-xset type))
+ (dolist (zero (member-type-fp-zeroes type))
+ (results (funcall function zero)))
+ (results)))
+
+(defun mapc-member-type-members (function type)
+ (declare (function function))
+ (map-xset function (member-type-xset type))
+ (dolist (zero (member-type-fp-zeroes type))
+ (funcall function zero)))
+
+(defun member-type-members (type)
+ (append (member-type-fp-zeroes type)
+ (xset-members (member-type-xset type))))
;;; A COMPOUND-TYPE is a type defined out of a set of types, the
;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
(mapcar #'do-complex (union-type-types ctype))))
((typep ctype 'member-type)
(apply #'type-union
- (mapcar (lambda (x) (do-complex (ctype-of x)))
- (member-type-members ctype))))
+ (mapcar-member-type-members
+ (lambda (x) (do-complex (ctype-of x)))
+ ctype)))
((and (typep ctype 'intersection-type)
;; FIXME: This is very much a
;; not-quite-worst-effort, but we are required to do
(!define-type-class member)
(!define-type-method (member :negate) (type)
- (let ((members (member-type-members type)))
- (if (some #'floatp members)
- (let (floats)
- (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
- (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
- #!+long-float
- (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))
- (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*
+ (let ((xset (member-type-xset type))
+ (fp-zeroes (member-type-fp-zeroes type)))
+ (if fp-zeroes
+ ;; Hairy case, which needs to do a bit of float type
+ ;; canonicalization.
+ (apply #'type-intersection
+ (if (xset-empty-p xset)
+ *universal-type*
+ (make-negation-type
+ :type (make-member-type :xset xset)))
+ (mapcar
+ (lambda (x)
+ (let* ((opposite (neg-fp-zero x))
+ (type (ctype-of opposite)))
+ (type-union
(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)))
+ :type (modified-numeric-type type :low nil :high nil))
+ (modified-numeric-type type :low nil :high (list opposite))
+ (make-member-type :members (list opposite))
+ (modified-numeric-type type :low (list opposite) :high nil))))
+ fp-zeroes))
+ ;; Easy case
(make-negation-type :type type))))
(!define-type-method (member :unparse) (type)
(t `(member ,@members)))))
(!define-type-method (member :simple-subtypep) (type1 type2)
- (values (subsetp (member-type-members type1) (member-type-members type2))
- t))
+ (values (and (xset-subset-p (member-type-xset type1)
+ (member-type-xset type2))
+ (subsetp (member-type-fp-zeroes type1)
+ (member-type-fp-zeroes type2)))
+ t))
(!define-type-method (member :complex-subtypep-arg1) (type1 type2)
- (every/type (swapped-args-fun #'ctypep)
- type2
- (member-type-members type1)))
+ (block punt
+ (mapc-member-type-members
+ (lambda (elt)
+ (multiple-value-bind (ok surep) (ctypep elt type2)
+ (unless surep
+ (return-from punt (values nil nil)))
+ (unless ok
+ (return-from punt (values nil t)))))
+ type1)
+ (values t t)))
;;; We punt if the odd type is enumerable and intersects with the
;;; MEMBER type. If not enumerable, then it is definitely not a
(t (values nil t))))
(!define-type-method (member :simple-intersection2) (type1 type2)
- (let ((mem1 (member-type-members type1))
- (mem2 (member-type-members type2)))
- (cond ((subsetp mem1 mem2) type1)
- ((subsetp mem2 mem1) type2)
- (t
- (let ((res (intersection mem1 mem2)))
- (if res
- (make-member-type :members res)
- *empty-type*))))))
+ (make-member-type :xset (xset-intersection (member-type-xset type1)
+ (member-type-xset type2))
+ :fp-zeroes (intersection (member-type-fp-zeroes type1)
+ (member-type-fp-zeroes type2))))
(!define-type-method (member :complex-intersection2) (type1 type2)
(block punt
- (collect ((members))
- (let ((mem2 (member-type-members type2)))
- (dolist (member mem2)
- (multiple-value-bind (val win) (ctypep member type1)
- (unless win
- (return-from punt nil))
- (when val (members member))))
- (cond ((subsetp mem2 (members)) type2)
- ((null (members)) *empty-type*)
- (t
- (make-member-type :members (members))))))))
+ (let ((xset (alloc-xset))
+ (fp-zeroes nil))
+ (mapc-member-type-members
+ (lambda (member)
+ (multiple-value-bind (ok sure) (ctypep member type1)
+ (unless sure
+ (return-from punt nil))
+ (when ok
+ (if (fp-zero-p member)
+ (pushnew member fp-zeroes)
+ (add-to-xset member xset)))))
+ type2)
+ (if (and (xset-empty-p xset) (not fp-zeroes))
+ *empty-type*
+ (make-member-type :xset xset :fp-zeroes fp-zeroes)))))
;;; We don't need a :COMPLEX-UNION2, since the only interesting case is
;;; a union type, and the member/union interaction is handled by the
;;; union type method.
(!define-type-method (member :simple-union2) (type1 type2)
- (let ((mem1 (member-type-members type1))
- (mem2 (member-type-members type2)))
- (cond ((subsetp mem1 mem2) type2)
- ((subsetp mem2 mem1) type1)
- (t
- (make-member-type :members (union mem1 mem2))))))
+ (make-member-type :xset (xset-union (member-type-xset type1)
+ (member-type-xset type2))
+ :fp-zeroes (union (member-type-fp-zeroes type1)
+ (member-type-fp-zeroes type2))))
(!define-type-method (member :simple-=) (type1 type2)
- (let ((mem1 (member-type-members type1))
- (mem2 (member-type-members type2)))
- (values (and (subsetp mem1 mem2)
- (subsetp mem2 mem1))
+ (let ((xset1 (member-type-xset type1))
+ (xset2 (member-type-xset type2))
+ (l1 (member-type-fp-zeroes type1))
+ (l2 (member-type-fp-zeroes type2)))
+ (values (and (eql (xset-count xset1) (xset-count xset2))
+ (xset-subset-p xset1 xset2)
+ (xset-subset-p xset2 xset1)
+ (subsetp l1 l2)
+ (subsetp l2 l1))
t)))
(!define-type-method (member :complex-=) (type1 type2)
(collect ((res))
(dolist (x-type x-types)
(if (member-type-p x-type)
- (collect ((members))
- (dolist (mem (member-type-members x-type))
- (multiple-value-bind (val win) (ctypep mem y)
- (unless win (return-from type-difference nil))
- (unless val
- (members mem))))
- (when (members)
- (res (make-member-type :members (members)))))
+ (let ((xset (alloc-xset))
+ (fp-zeroes nil))
+ (mapc-member-type-members
+ (lambda (elt)
+ (multiple-value-bind (ok sure) (ctypep elt y)
+ (unless sure
+ (return-from type-difference nil))
+ (unless ok
+ (if (fp-zero-p elt)
+ (pushnew elt fp-zeroes)
+ (add-to-xset elt xset)))))
+ x-type)
+ (unless (and (xset-empty-p xset) (not fp-zeroes))
+ (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
(dolist (y-type y-types (res x-type))
(multiple-value-bind (val win) (csubtypep x-type y-type)
(unless win (return-from type-difference nil))
(return-from type-difference nil))))))
(let ((y-mem (find-if #'member-type-p y-types)))
(when y-mem
- (let ((members (member-type-members y-mem)))
- (dolist (x-type x-types)
- (unless (member-type-p x-type)
- (dolist (member members)
- (multiple-value-bind (val win) (ctypep member x-type)
- (when (or (not win) val)
- (return-from type-difference nil)))))))))
+ (dolist (x-type x-types)
+ (unless (member-type-p x-type)
+ (mapc-member-type-members
+ (lambda (member)
+ (multiple-value-bind (ok sure) (ctypep member x-type)
+ (when (or (not sure) ok)
+ (return-from type-difference nil))))
+ y-mem)))))
(apply #'type-union (res)))))
\f
(!def-type-translator array (&optional (element-type '*)
(specifier-type (array-element-type
object)))))))
(member-type
- (if (member object (member-type-members type)) t))
+ (when (member-type-member-p object type)
+ t))
(classoid
#+sb-xc-host (ctypep object type)
#-sb-xc-host (classoid-typep (layout-of object) type object))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;;; XSET
+;;;;
+;;;; A somewhat effcient set implementation that can store arbitrary
+;;;; objects. For small sets the data is stored in a list, but when
+;;;; the amount of elements grows beyond +XSET-LIST-SIZE-LIMIT+, we
+;;;; switch to a hash-table instead.
+;;;;
+;;;; ALLOC-XSET allocates an empty XSET. ADD-TO-XSET adds an element
+;;;; to an XSET: it should be used only on freshly allocated XSETs.
+;;;;
+;;;; XSET-EMPTY-P, XSET-INTERSECTION, XSET-SUBSET-P, and XSET-MEMBER-P
+;;;; do the obvious things. MAP-XSET maps over the element, but
+;;;; requires a function as the first argument -- not a function
+;;;; designator.
+;;;;
+;;;; XSET-LIST-SIZE is true only for XSETs whose data is stored into a
+;;;; list -- XSET-COUNT returns the real value.
+
+(in-package "SB!KERNEL")
+
+#!-sb-fluid
+(declaim (inline alloc-xset xset-data (setf xset-data) xset-list-size (setf xset-list-size)))
+(defstruct (xset (:constructor alloc-xset) (:copier nil) (:predicate nil))
+ (list-size 0 :type index)
+ (data nil :type (or list hash-table)))
+
+(defun xset-count (xset)
+ (let ((data (xset-data xset)))
+ (if (listp data)
+ (xset-list-size xset)
+ (hash-table-count data))))
+
+(defun map-xset (function xset)
+ (declare (function function))
+ (let ((data (xset-data xset)))
+ (if (listp data)
+ (dolist (elt data)
+ (funcall function elt))
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (funcall function k))
+ data)))
+ nil)
+
+(defconstant +xset-list-size-limit+ 12)
+
+;;; Checks that the element is not in the set yet.
+(defun add-to-xset (elt xset)
+ (let ((data (xset-data xset))
+ (size (xset-list-size xset)))
+ (if (listp data)
+ (if (< size +xset-list-size-limit+)
+ (unless (member elt data :test #'eq)
+ (setf (xset-list-size xset) (1+ size)
+ (xset-data xset) (cons elt data)))
+ (let ((table (make-hash-table :size (* 2 size) :test #'eq)))
+ (setf (gethash elt table) t)
+ (dolist (x data)
+ (setf (gethash x table) t))
+ (setf (xset-data xset) table)))
+ (setf (gethash elt data) t))))
+
+(defun xset-union (a b)
+ (let ((xset (alloc-xset)))
+ (map-xset (lambda (x)
+ (add-to-xset x xset))
+ a)
+ (map-xset (lambda (y)
+ (add-to-xset y xset))
+ b)
+ xset))
+
+(defun xset-member-p (elt xset)
+ (let ((data (xset-data xset)))
+ (if (listp data)
+ (member elt data :test #'eq)
+ (gethash elt data))))
+
+(defun xset-members (xset)
+ (let ((data (xset-data xset)))
+ (if (listp data)
+ data
+ (let (members)
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (push k members))
+ data)
+ members))))
+
+(defun xset-intersection (a b)
+ (let ((intersection (alloc-xset)))
+ (multiple-value-bind (source lookup)
+ (if (< (xset-list-size a) (xset-list-size b))
+ (values b a)
+ (values a b))
+ (let ((data (xset-data lookup)))
+ (map-xset (if (listp data)
+ (lambda (elt)
+ (when (member elt data :test #'eq)
+ (add-to-xset elt intersection)))
+ (lambda (elt)
+ (when (gethash elt data)
+ (add-to-xset elt intersection))))
+ source)))
+ intersection))
+
+(defun xset-subset-p (xset1 xset2)
+ (when (<= (xset-count xset1) (xset-count xset2))
+ (let ((data (xset-data xset2)))
+ (map-xset
+ (if (listp data)
+ (lambda (elt)
+ (unless (member elt data :test #'eq)
+ (return-from xset-subset-p nil)))
+ (lambda (elt)
+ (unless (gethash elt data)
+ (return-from xset-subset-p nil))))
+ xset1))
+ t))
+
+#!-sb-fluid (declaim (inline xset-empty-p))
+(defun xset-empty-p (xset)
+ (not (xset-data xset)))
(compound-type
(reduce #'+ (compound-type-types type) :key 'type-test-cost))
(member-type
- (* (length (member-type-members type))
+ (* (member-type-size type)
(fun-guessed-cost 'eq)))
(numeric-type
(* (if (numeric-type-complexp type) 2 1)
(!def-vm-support-routine primitive-type-of (object)
(let ((type (ctype-of object)))
(cond ((not (member-type-p type)) (primitive-type type))
- ((equal (member-type-members type) '(nil))
+ ((and (eql 1 (member-type-size type))
+ (equal (member-type-members type) '(nil)))
(primitive-type-or-lose 'list))
(t
*backend-t-primitive-type*))))
;; Punt.
(t (return (any))))))))
(member-type
- (let* ((members (member-type-members type))
- (res (primitive-type-of (first members))))
- (dolist (mem (rest members) (values res nil))
- (let ((ptype (primitive-type-of mem)))
- (unless (eq ptype res)
- (let ((new-ptype (or (maybe-numeric-type-union res ptype)
- (maybe-numeric-type-union ptype res))))
- (if new-ptype
- (setq res new-ptype)
- (return (any)))))))))
+ (let (res)
+ (block nil
+ (mapc-member-type-members
+ (lambda (member)
+ (let ((ptype (primitive-type-of member)))
+ (if res
+ (unless (eq ptype res)
+ (let ((new-ptype (or (maybe-numeric-type-union res ptype)
+ (maybe-numeric-type-union ptype res))))
+ (if new-ptype
+ (setq res new-ptype)
+ (return (any)))))
+ (setf res ptype))))
+ type))
+ res))
(named-type
(ecase (named-type-name type)
((t *) (values *backend-t-primitive-type* t))
((or (null current) (eq res *wild-type*))
res)))
(t
- (node-derived-type (lvar-uses lvar))))))
+ (node-derived-type uses)))))
;;; Return the derived type for LVAR's first value. This is guaranteed
;;; not to be a VALUES or FUNCTION type.
(lambda-var-p (ref-leaf node)))
(let ((type (single-value-type int)))
(when (and (member-type-p type)
- (null (rest (member-type-members type))))
+ (eql 1 (member-type-size type)))
(change-ref-leaf node (find-constant
(first (member-type-members type)))))))
(reoptimize-lvar lvar)))))
*policy*)))
(setf (cast-type-to-check cast) *wild-type*)
(substitute-lvar-uses value arg
- ;; FIXME
- t)
+ ;; FIXME
+ t)
(%delete-lvar-use ref)
(add-lvar-use cast lvar)))))
(setf (node-derived-type ref) *wild-type*)
;;; right here.
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
-
(unless (or (functional-entry-fun fun)
(lambda-optional-dispatch fun))
(let* ((vars (lambda-vars fun))
(if (member-type-p arg)
;; Run down the list of members and convert to a list of
;; member types.
- (dolist (member (member-type-members arg))
- (push (if (numberp member)
- (make-member-type :members (list member))
- *empty-type*)
- new-args))
+ (mapc-member-type-members
+ (lambda (member)
+ (push (if (numberp member)
+ (make-member-type :members (list member))
+ *empty-type*)
+ new-args))
+ arg)
(push arg new-args)))
(unless (member *empty-type* new-args)
new-args)))))
;;; XXX This would be far simpler if the type-union methods could handle
;;; member/number unions.
(defun make-canonical-union-type (type-list)
- (let ((members '())
+ (let ((xset (alloc-xset))
+ (fp-zeroes '())
(misc-types '()))
(dolist (type type-list)
- (if (member-type-p type)
- (setf members (union members (member-type-members type)))
- (push type misc-types)))
- #!+long-float
- (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))
- (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))
- (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))
- (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))
- (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
- (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))
- (if members
- (apply #'type-union (make-member-type :members members) misc-types)
- (apply #'type-union misc-types))))
+ (cond ((member-type-p type)
+ (mapc-member-type-members
+ (lambda (member)
+ (if (fp-zero-p member)
+ (unless (member member fp-zeroes)
+ (pushnew member fp-zeroes))
+ (add-to-xset member xset)))
+ type))
+ (t
+ (push type misc-types))))
+ (if (and (xset-empty-p xset) (not fp-zeroes))
+ (apply #'type-union misc-types)
+ (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types))))
;;; Convert a member type with a single member to a numeric type.
(defun convert-member-type (arg)
;; we're prepared to handle which is basically something
;; that array-element-type can return.
(or (and (member-type-p cons-type)
- (null (rest (member-type-members cons-type)))
+ (eql 1 (member-type-size cons-type))
(null (first (member-type-members cons-type))))
(let ((car-type (cons-type-car-type cons-type)))
(and (member-type-p car-type)
- (null (rest (member-type-members car-type)))
- (or (symbolp (first (member-type-members car-type)))
- (numberp (first (member-type-members car-type)))
- (and (listp (first (member-type-members
- car-type)))
- (numberp (first (first (member-type-members
- car-type))))))
+ (eql 1 (member-type-members car-type))
+ (let ((elt (first (member-type-members car-type))))
+ (or (symbolp elt)
+ (numberp elt)
+ (and (listp elt)
+ (numberp (first elt)))))
(good-cons-type-p (cons-type-cdr-type cons-type))))))
(unconsify-type (good-cons-type)
;; Convert the "printed" respresentation of a cons
;; (DOUBLE-FLOAT 10d0 20d0) instead of just
;; double-float.
(cond ((member-type-p type)
- (let ((members (member-type-members type)))
- (if (every #'coerceable-p members)
- (specifier-type `(or ,@members))
- *universal-type*)))
+ (block punt
+ (let (members)
+ (mapc-member-type-members
+ (lambda (member)
+ (if (coerceable-p member)
+ (push member members)
+ (return-from punt *universal-type*)))
+ type)
+ (specifier-type `(or ,@members)))))
((and (cons-type-p type)
(good-cons-type-p type))
(let ((c-type (unconsify-type (type-specifier type))))
(defvar *gray-binary-data*
(let ((vector (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0)))
- (dotimes (i (length vector))
+ (dotimes (i (length vector))
(setf (aref vector i) (random 256)))
vector))
(dotimes (i 1024)
(unless (eql (aref *gray-binary-data* i)
(aref binary-buffer i))
- (error "wanted ~S at ~S, got ~S (~S)"
+ (error "wanted ~S at ~S, got ~S (~S)"
(aref *gray-binary-data* i)
- i
+ i
(aref binary-buffer i)
stream))))))
;;; 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".)
-"1.0.12.17"
+"1.0.12.18"
projects / sbcl.git / commitdiff