(result)))
(!def-type-translator function (&optional (args '*) (result '*))
- (make-fun-type :args args
- :returns (coerce-to-values (values-specifier-type result))))
+ (let ((result (coerce-to-values (values-specifier-type result))))
+ (if (eq args '*)
+ (if (eq result *wild-type*)
+ (specifier-type 'function)
+ (make-fun-type :wild-args t :returns result))
+ (multiple-value-bind (required optional rest keyp keywords allowp)
+ (parse-args-types args)
+ (if (and (null required)
+ (null optional)
+ (eq rest *universal-type*)
+ (not keyp))
+ (if (eq result *wild-type*)
+ (specifier-type 'function)
+ (make-fun-type :wild-args t :returns result))
+ (make-fun-type :required required
+ :optional optional
+ :rest rest
+ :keyp keyp
+ :keywords keywords
+ :allowp allowp
+ :returns result))))))
(!def-type-translator values (&rest values)
- (make-values-type :args values))
+ (if (eq values '*)
+ *wild-type*
+ (multiple-value-bind (required optional rest keyp keywords allowp llk-p)
+ (parse-args-types values)
+ (declare (ignore keywords))
+ (cond (keyp
+ (error "&KEY appeared in a VALUES type specifier ~S."
+ `(values ,@values)))
+ (llk-p
+ (make-values-type :required required
+ :optional optional
+ :rest rest
+ :allowp allowp))
+ (t
+ (make-short-values-type required))))))
\f
;;;; VALUES types interfaces
;;;;
;;;; We provide a few special operations that can be meaningfully used
;;;; on VALUES types (as well as on any other type).
+;;; Return the minimum number of values possibly matching VALUES type
+;;; TYPE.
+(defun values-type-min-value-count (type)
+ (etypecase type
+ (named-type
+ (ecase (named-type-name type)
+ ((t *) 0)
+ ((nil) 0)))
+ (values-type
+ (length (values-type-required type)))))
+
+;;; Return the maximum number of values possibly matching VALUES type
+;;; TYPE.
+(defun values-type-max-value-count (type)
+ (etypecase type
+ (named-type
+ (ecase (named-type-name type)
+ ((t *) call-arguments-limit)
+ ((nil) 0)))
+ (values-type
+ (if (values-type-rest type)
+ call-arguments-limit
+ (+ (length (values-type-optional type))
+ (length (values-type-required type)))))))
+
+(defun values-type-may-be-single-value-p (type)
+ (<= (values-type-min-value-count type)
+ 1
+ (values-type-max-value-count type)))
+
(defun type-single-value-p (type)
(and (values-type-p type)
(not (values-type-rest type))
;; required to be a subclass of STANDARD-OBJECT. -- CSR,
;; 2005-09-09
(frob instance *instance-type*)
- (frob funcallable-instance *funcallable-instance-type*))
+ (frob funcallable-instance *funcallable-instance-type*)
+ ;; new in sbcl-1.0.3.3: necessary to act as a join point for the
+ ;; extended sequence hierarchy. (Might be removed later if we use
+ ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.)
+ (frob extended-sequence *extended-sequence-type*))
(setf *universal-fun-type*
(make-fun-type :wild-args t
:returns *wild-type*)))
;; member types can be subtypep INSTANCE and
;; FUNCALLABLE-INSTANCE in surprising ways.
(invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (eq type2 *extended-sequence-type*) (classoid-p type1))
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (sequencep (find (classoid-layout (find-classoid 'sequence))
+ inherits)))
+ (values (if sequencep t nil) t)))
((and (eq type2 *instance-type*) (classoid-p type1))
(if (member type1 *non-instance-classoid-types* :key #'find-classoid)
(values nil t)
;; Perhaps when bug 85 is fixed it can be reenabled.
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond
+ ((eq type2 *extended-sequence-type*)
+ (typecase type1
+ (structure-classoid *empty-type*)
+ (classoid
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ *empty-type*
+ (if (find (classoid-layout (find-classoid 'sequence))
+ (layout-inherits (classoid-layout type1)))
+ type1
+ nil)))
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
((eq type2 *instance-type*)
(typecase type1
(structure-classoid type1)
;; Perhaps when bug 85 is fixed this can be reenabled.
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond
+ ((eq type2 *extended-sequence-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (not (find (classoid-layout (find-classoid 'sequence))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ type2)
+ nil))
((eq type2 *instance-type*)
(if (classoid-p type1)
(if (or (member type1 *non-instance-classoid-types*
((eq x *universal-type*) *empty-type*)
((eq x *empty-type*) *universal-type*)
((or (eq x *instance-type*)
- (eq x *funcallable-instance-type*))
+ (eq x *funcallable-instance-type*)
+ (eq x *extended-sequence-type*))
(make-negation-type :type x))
(t (bug "NAMED type unexpected: ~S" x))))
(hairy-spec2 (hairy-type-specifier type2)))
(cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2)
(values t t))
+ ((maybe-reparse-specifier! type1)
+ (csubtypep type1 type2))
+ ((maybe-reparse-specifier! type2)
+ (csubtypep type1 type2))
(t
(values nil nil)))))
(!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
- (invoke-complex-subtypep-arg1-method type1 type2))
+ (if (maybe-reparse-specifier! type2)
+ (csubtypep type1 type2)
+ (let ((specifier (hairy-type-specifier type2)))
+ (cond ((and (consp specifier) (eql (car specifier) 'satisfies))
+ (case (cadr specifier)
+ ((keywordp) (if (type= type1 (specifier-type 'symbol))
+ (values nil t)
+ (invoke-complex-subtypep-arg1-method type1 type2)))
+ (t (invoke-complex-subtypep-arg1-method type1 type2))))
+ (t
+ (invoke-complex-subtypep-arg1-method type1 type2))))))
(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
- (declare (ignore type1 type2))
- (values nil nil))
+ (if (maybe-reparse-specifier! type1)
+ (csubtypep type1 type2)
+ (values nil nil)))
(!define-type-method (hairy :complex-=) (type1 type2)
- (if (and (unknown-type-p type2)
- (let* ((specifier2 (unknown-type-specifier type2))
- (name2 (if (consp specifier2)
- (car specifier2)
- specifier2)))
- (info :type :kind name2)))
- (let ((type2 (specifier-type (unknown-type-specifier type2))))
- (if (unknown-type-p type2)
- (values nil nil)
- (type= type1 type2)))
- (values nil nil)))
+ (if (maybe-reparse-specifier! type2)
+ (type= type1 type2)
+ (values nil nil)))
(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
(type1 type2)
(aver (not (eq (type-union not1 not2) *universal-type*)))
nil))))
+(defun maybe-complex-array-refinement (type1 type2)
+ (let* ((ntype (negation-type-type type2))
+ (ndims (array-type-dimensions ntype))
+ (ncomplexp (array-type-complexp ntype))
+ (nseltype (array-type-specialized-element-type ntype))
+ (neltype (array-type-element-type ntype)))
+ (if (and (eql ndims '*) (null ncomplexp)
+ (eql neltype *wild-type*) (eql nseltype *wild-type*))
+ (make-array-type :dimensions (array-type-dimensions type1)
+ :complexp t
+ :element-type (array-type-element-type type1)
+ :specialized-element-type (array-type-specialized-element-type type1)))))
+
(!define-type-method (negation :complex-intersection2) (type1 type2)
(cond
((csubtypep type1 (negation-type-type type2)) *empty-type*)
((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
type1)
+ ((and (array-type-p type1) (array-type-p (negation-type-type type2)))
+ (maybe-complex-array-refinement type1 type2))
(t nil)))
(!define-type-method (negation :simple-union2) (type1 type2)
(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
(complexp (array-type-complexp type)))
(cond ((eq dims '*)
(if (eq eltype '*)
- (if complexp 'array 'simple-array)
- (if complexp `(array ,eltype) `(simple-array ,eltype))))
+ (ecase complexp
+ ((t) '(and array (not simple-array)))
+ ((:maybe) 'array)
+ ((nil) 'simple-array))
+ (ecase complexp
+ ((t) `(and (array ,eltype) (not simple-array)))
+ ((:maybe) `(array ,eltype))
+ ((nil) `(simple-array ,eltype)))))
((= (length dims) 1)
(if complexp
- (if (eq (car dims) '*)
- (case eltype
- (bit 'bit-vector)
- ((base-char #!-sb-unicode character) 'base-string)
- (* 'vector)
- (t `(vector ,eltype)))
- (case eltype
- (bit `(bit-vector ,(car dims)))
- ((base-char #!-sb-unicode character)
- `(base-string ,(car dims)))
- (t `(vector ,eltype ,(car dims)))))
+ (let ((answer
+ (if (eq (car dims) '*)
+ (case eltype
+ (bit 'bit-vector)
+ ((base-char #!-sb-unicode character) 'base-string)
+ (* 'vector)
+ (t `(vector ,eltype)))
+ (case eltype
+ (bit `(bit-vector ,(car dims)))
+ ((base-char #!-sb-unicode character)
+ `(base-string ,(car dims)))
+ (t `(vector ,eltype ,(car dims)))))))
+ (if (eql complexp :maybe)
+ answer
+ `(and ,answer (not simple-array))))
(if (eq (car dims) '*)
(case eltype
(bit 'simple-bit-vector)
((t) `(simple-vector ,(car dims)))
(t `(simple-array ,eltype ,dims))))))
(t
- (if complexp
- `(array ,eltype ,dims)
- `(simple-array ,eltype ,dims))))))
+ (ecase complexp
+ ((t) `(and (array ,eltype ,dims) (not simple-array)))
+ ((:maybe) `(array ,eltype ,dims))
+ ((nil) `(simple-array ,eltype ,dims)))))))
(!define-type-method (array :simple-subtypep) (type1 type2)
(let ((dims1 (array-type-dimensions type1))
(!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)
;;; type without that particular element. This seems too hairy to be
;;; worthwhile, given its low utility.
(defun type-difference (x y)
- (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
- (y-types (if (union-type-p y) (union-type-types y) (list y))))
- (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)))))
- (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))
- (when val (return))
- (when (types-equal-or-intersect x-type y-type)
- (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)))))))))
- (apply #'type-union (res)))))
+ (if (and (numeric-type-p x) (numeric-type-p y))
+ ;; Numeric types are easy. Are there any others we should handle like this?
+ (type-intersection x (type-negation y))
+ (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
+ (y-types (if (union-type-p y) (union-type-types y) (list y))))
+ (collect ((res))
+ (dolist (x-type x-types)
+ (if (member-type-p x-type)
+ (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))
+ (when val (return))
+ (when (types-equal-or-intersect x-type y-type)
+ (return-from type-difference nil))))))
+ (let ((y-mem (find-if #'member-type-p y-types)))
+ (when y-mem
+ (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 '*)
(dimensions '*))
projects / sbcl.git / blobdiff