(define-condition parse-unknown-type (condition)
((specifier :reader parse-unknown-type-specifier :initarg :specifier)))
-;;; 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.)
-(defvar *use-implementation-types* t ; actually initialized in cold init
- #!+sb-doc
- "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how
- restrictive we are in determining type membership. If two types are the
- same in the implementation, then we will consider them them the same when
- this switch is on. When it is off, we try to be as restrictive as the
- language allows, allowing us to detect more errors. Currently, this only
- affects array types.")
-(!cold-init-forms (setq *use-implementation-types* t))
-
;;; These functions are used as method for types which need a complex
;;; subtypep method to handle some superclasses, but cover a subtree
;;; of the type graph (i.e. there is no simple way for any other type
(funcall method type2 type1)
(hierarchical-intersection2 type1 type2))))
+(defun contains-unknown-type-p (ctype)
+ (cond ((unknown-type-p ctype) t)
+ ((intersection-type-p ctype)
+ (some #'contains-unknown-type-p (intersection-type-types ctype)))
+ ((union-type-p ctype)
+ (some #'contains-unknown-type-p (union-type-types ctype)))))
+
;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
;;; method. INFO is a list of conses
;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).
(!cold-init-forms (setq *unparse-fun-type-simplify* nil))
(!define-type-method (function :negate) (type)
- (error "NOT FUNCTION too confusing on ~S" (type-specifier type)))
+ (make-negation-type :type type))
(!define-type-method (function :unparse) (type)
(if *unparse-fun-type-simplify*
(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)))
+
+;;; VALUES type with a single value.
(defun type-single-value-p (type)
- (and (values-type-p type)
+ (and (%values-type-p type)
(not (values-type-rest type))
(null (values-type-optional type))
(singleton-p (values-type-required type))))
*empty-type*)
((not (values-type-p type))
type)
- (t (or (car (args-type-required type))
- (car (args-type-optional type))
- (args-type-rest type)
- (specifier-type 'null)))))
+ ((car (args-type-required type)))
+ (t (type-union (specifier-type 'null)
+ (or (car (args-type-optional type))
+ (args-type-rest type)
+ (specifier-type 'null))))))
;;; Return the minimum number of arguments that a function can be
;;; called with, and the maximum number or NIL. If not a function
:rest rest)
exactp)))
+(defun compare-key-args (type1 type2)
+ (let ((keys1 (args-type-keywords type1))
+ (keys2 (args-type-keywords type2)))
+ (and (= (length keys1) (length keys2))
+ (eq (args-type-allowp type1)
+ (args-type-allowp type2))
+ (loop for key1 in keys1
+ for match = (find (key-info-name key1)
+ keys2 :key #'key-info-name)
+ always (and match
+ (type= (key-info-type key1)
+ (key-info-type match)))))))
+
(defun type=-args (type1 type2)
(macrolet ((compare (comparator field)
(let ((reader (symbolicate '#:args-type- field)))
(and/type (and/type (compare type=-list required)
(compare type=-list optional))
(if (or (args-type-keyp type1) (args-type-keyp type2))
- (values nil nil)
+ (values (compare-key-args type1 type2) t)
(values t t))))))
;;; Do a union or intersection operation on types that might be values
;; e.g. fading away in favor of some CLOS solution) the shared logic
;; should probably become shared code. -- WHN 2001-03-16
(declare (type ctype type1 type2))
- (cond ((eq type1 type2)
- type1)
- ((csubtypep type1 type2) type2)
- ((csubtypep type2 type1) type1)
- ((or (union-type-p type1)
- (union-type-p type2))
- ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
- ;; values broken out and united separately. The full TYPE-UNION
- ;; function knows how to do this, so let it handle it.
- (type-union type1 type2))
- (t
- ;; the ordinary case: we dispatch to type methods
- (%type-union2 type1 type2))))
+ (let ((t2 nil))
+ (cond ((eq type1 type2)
+ type1)
+ ;; CSUBTYPEP for array-types answers questions about the
+ ;; specialized type, yet for union we want to take the
+ ;; expressed type in account too.
+ ((and (not (and (array-type-p type1) (array-type-p type2)))
+ (or (setf t2 (csubtypep type1 type2))
+ (csubtypep type2 type1)))
+ (if t2 type2 type1))
+ ((or (union-type-p type1)
+ (union-type-p type2))
+ ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
+ ;; values broken out and united separately. The full TYPE-UNION
+ ;; function knows how to do this, so let it handle it.
+ (type-union type1 type2))
+ (t
+ ;; the ordinary case: we dispatch to type methods
+ (%type-union2 type1 type2)))))
;;; the type method dispatch case of TYPE-INTERSECTION2
(defun %type-intersection2 (type1 type2)
(eql yx :call-other-method))
*empty-type*)
(t
- (aver (and (not xy) (not yx))) ; else handled above
nil))))))))
(defun-cached (type-intersection2 :hash-function type-cache-hash
(declare (type ctype type))
(funcall (type-class-negate (type-class-info type)) type))
+(defun-cached (type-singleton-p :hash-function (lambda (type)
+ (logand (type-hash-value type)
+ #xff))
+ :hash-bits 8
+ :values 2
+ :default (values nil t)
+ :init-wrapper !cold-init-forms)
+ ((type eq))
+ (declare (type ctype type))
+ (let ((function (type-class-singleton-p (type-class-info type))))
+ (if function
+ (funcall function type)
+ (values nil nil))))
+
;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
;;; early-type.lisp by WHN ca. 19990201.)
;; In SBCL it also used to denote universal VALUES type.
(frob * *wild-type*)
(frob nil *empty-type*)
- (frob t *universal-type*))
+ (frob t *universal-type*)
+ ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that
+ ;; view of them was incompatible with requirements on the MOP
+ ;; metaobject class hierarchy: the INSTANCE and
+ ;; FUNCALLABLE-INSTANCE types are disjoint (instances have
+ ;; instance-pointer-lowtag; funcallable-instances have
+ ;; fun-pointer-lowtag), while FUNCALLABLE-STANDARD-OBJECT is
+ ;; required to be a subclass of STANDARD-OBJECT. -- CSR,
+ ;; 2005-09-09
+ (frob instance *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*)))
;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
+(defun cons-type-might-be-empty-type (type)
+ (declare (type cons-type type))
+ (let ((car-type (cons-type-car-type type))
+ (cdr-type (cons-type-cdr-type type)))
+ (or
+ (if (cons-type-p car-type)
+ (cons-type-might-be-empty-type car-type)
+ (multiple-value-bind (yes surep)
+ (type= car-type *empty-type*)
+ (aver (not yes))
+ (not surep)))
+ (if (cons-type-p cdr-type)
+ (cons-type-might-be-empty-type cdr-type)
+ (multiple-value-bind (yes surep)
+ (type= cdr-type *empty-type*)
+ (aver (not yes))
+ (not surep))))))
+
(!define-type-method (named :complex-=) (type1 type2)
(cond
((and (eq type2 *empty-type*)
- (intersection-type-p type1)
- ;; not allowed to be unsure on these... FIXME: keep the list
- ;; of CL types that are intersection types once and only
- ;; once.
- (not (or (type= type1 (specifier-type 'ratio))
- (type= type1 (specifier-type 'keyword)))))
+ (or (and (intersection-type-p type1)
+ ;; not allowed to be unsure on these... FIXME: keep
+ ;; the list of CL types that are intersection types
+ ;; once and only once.
+ (not (or (type= type1 (specifier-type 'ratio))
+ (type= type1 (specifier-type 'keyword)))))
+ (and (cons-type-p type1)
+ (cons-type-might-be-empty-type type1))))
;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
;; STREAM) can get here. In general, we can't really tell
;; whether these are equal to NIL or not, so
(!define-type-method (named :simple-subtypep) (type1 type2)
(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
- (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
+ (aver (not (eq type1 type2)))
+ (values (or (eq type1 *empty-type*)
+ (eq type2 *wild-type*)
+ (eq type2 *universal-type*)) t))
(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
;; This AVER causes problems if we write accurate methods for the
;; is a compound type which might contain a hairy type) by
;; returning uncertainty.
(values nil nil))
+ ((eq type1 *funcallable-instance-type*)
+ (values (eq type2 (specifier-type 'function)) t))
(t
- ;; By elimination, TYPE1 is the universal type.
- (aver (eq type1 *universal-type*))
;; This case would have been picked off by the SIMPLE-SUBTYPEP
;; method, and so shouldn't appear here.
- (aver (not (eq type2 *universal-type*)))
- ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the
- ;; universal type in disguise, TYPE2 is not a superset of TYPE1.
+ (aver (not (named-type-p type2)))
+ ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another
+ ;; named type in disguise, TYPE2 is not a superset of TYPE1.
(values nil t))))
(!define-type-method (named :complex-subtypep-arg2) (type1 type2)
(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond ((eq type2 *universal-type*)
(values t t))
+ ;; some CONS types can conceal danger
+ ((and (cons-type-p type1) (cons-type-might-be-empty-type type1))
+ (values nil nil))
((type-might-contain-other-types-p type1)
- ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in
- ;; disguise. So we'd better delegate.
+ ;; those types can be other types in disguise. So we'd
+ ;; better delegate.
+ (invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (or (eq type2 *instance-type*)
+ (eq type2 *funcallable-instance-type*))
+ (member-type-p type1))
+ ;; 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)
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (functionp (find (classoid-layout (find-classoid 'function))
+ inherits)))
+ (cond
+ (functionp
+ (values nil t))
+ ((eq type1 (find-classoid 'function))
+ (values nil t))
+ ((or (structure-classoid-p type1)
+ #+nil
+ (condition-classoid-p type1))
+ (values t t))
+ (t (values nil nil))))))
+ ((and (eq type2 *funcallable-instance-type*) (classoid-p type1))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ (values nil t)
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (functionp (find (classoid-layout (find-classoid 'function))
+ inherits)))
+ (values (if functionp t nil) t))))
(t
- ;; FIXME: This seems to rely on there only being 2 or 3
+ ;; FIXME: This seems to rely on there only being 4 or 5
;; NAMED-TYPE values, and the exclusion of various
;; possibilities above. It would be good to explain it and/or
;; rewrite it so that it's clearer.
- (values (not (eq type2 *empty-type*)) t))))
+ (values nil t))))
(!define-type-method (named :complex-intersection2) (type1 type2)
;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
;; Perhaps when bug 85 is fixed it can be reenabled.
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
- (hierarchical-intersection2 type1 type2))
+ (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)
+ (classoid
+ (if (and (not (member type1 *non-instance-classoid-types*
+ :key #'find-classoid))
+ (not (eq type1 (find-classoid 'function)))
+ (not (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ *empty-type*))
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
+ ((eq type2 *funcallable-instance-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 'function))
+ (layout-inherits (classoid-layout type1)))
+ type1
+ (if (type= type1 (find-classoid 'function))
+ type2
+ nil))))
+ (fun-type nil)
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
+ (t (hierarchical-intersection2 type1 type2))))
(!define-type-method (named :complex-union2) (type1 type2)
;; Perhaps when bug 85 is fixed this can be reenabled.
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
- (hierarchical-union2 type1 type2))
+ (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*
+ :key #'find-classoid)
+ (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1))))
+ nil
+ type2)
+ nil))
+ ((eq type2 *funcallable-instance-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (not (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ (if (eq type1 (specifier-type 'function))
+ type1
+ type2))
+ nil))
+ (t (hierarchical-union2 type1 type2))))
(!define-type-method (named :negate) (x)
(aver (not (eq x *wild-type*)))
(cond
((eq x *universal-type*) *empty-type*)
((eq x *empty-type*) *universal-type*)
- (t (bug "NAMED type not universal, wild or empty: ~S" x))))
+ ((or (eq x *instance-type*)
+ (eq x *funcallable-instance-type*)
+ (eq x *extended-sequence-type*))
+ (make-negation-type :type x))
+ (t (bug "NAMED type unexpected: ~S" x))))
(!define-type-method (named :unparse) (x)
(named-type-name 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)
(aver (eq base+bounds 'real))
'number)))))
+(!define-type-method (number :singleton-p) (type)
+ (let ((low (numeric-type-low type))
+ (high (numeric-type-high type)))
+ (if (and low
+ (eql low high)
+ (eql (numeric-type-complexp type) :real)
+ (member (numeric-type-class type) '(integer rational
+ #-sb-xc-host float)))
+ (values t (numeric-type-low type))
+ (values nil nil))))
+
;;; Return true if X is "less than or equal" to Y, taking open bounds
;;; into consideration. CLOSED is the predicate used to test the bound
;;; on a closed interval (e.g. <=), and OPEN is the predicate used on
;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
;;;
-;;; Old comment, probably no longer applicable:
-;;;
-;;; ### Note: we give up early to keep from dropping lots of
-;;; information on the floor by returning overly general types.
+;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent
+;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128),
+;;; the compiler does this occasionally during type-derivation to avoid
+;;; creating absurdly complex unions of numeric types.
+(defvar *approximate-numeric-unions* nil)
+
(!define-type-method (number :simple-union2) (type1 type2)
(declare (type numeric-type type1 type2))
(cond ((csubtypep type1 type2) type2)
((and (eq class1 class2)
(eq format1 format2)
(eq complexp1 complexp2)
- (or (numeric-types-intersect type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-intersect type1 type2)
(numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
(integerp (numeric-type-low type2))
(integerp (numeric-type-high type2))
(= (numeric-type-low type2) (numeric-type-high type2))
- (or (numeric-types-adjacent type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
:class 'rational
(integerp (numeric-type-low type1))
(integerp (numeric-type-high type1))
(= (numeric-type-low type1) (numeric-type-high type1))
- (or (numeric-types-adjacent type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
:class 'rational
(if (csubtypep component-type (specifier-type '(eql 0)))
*empty-type*
(modified-numeric-type component-type
- :complexp :complex))))
+ :complexp :complex)))
+ (do-complex (ctype)
+ (cond
+ ((eq ctype *empty-type*) *empty-type*)
+ ((eq ctype *universal-type*) (not-real))
+ ((typep ctype 'numeric-type) (complex1 ctype))
+ ((typep ctype 'union-type)
+ (apply #'type-union
+ (mapcar #'do-complex (union-type-types ctype))))
+ ((typep ctype 'member-type)
+ (apply #'type-union
+ (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
+ ;; something here because of our representation of
+ ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
+ ;; allow users to ask about (COMPLEX RATIO). This
+ ;; will of course fail to work right on such types
+ ;; as (AND INTEGER (SATISFIES ZEROP))...
+ (let ((numbers (remove-if-not
+ #'numeric-type-p
+ (intersection-type-types ctype))))
+ (and (car numbers)
+ (null (cdr numbers))
+ (eq (numeric-type-complexp (car numbers)) :real)
+ (complex1 (car numbers))))))
+ (t
+ (multiple-value-bind (subtypep certainly)
+ (csubtypep ctype (specifier-type 'real))
+ (if (and (not subtypep) certainly)
+ (not-real)
+ ;; ANSI just says that TYPESPEC is any subtype of
+ ;; type REAL, not necessarily a NUMERIC-TYPE. In
+ ;; particular, at this point TYPESPEC could legally
+ ;; be a hairy type like (AND NUMBER (SATISFIES
+ ;; REALP) (SATISFIES ZEROP)), in which case we fall
+ ;; through the logic above and end up here,
+ ;; stumped.
+ (bug "~@<(known bug #145): The type ~S is too hairy to be ~
+used for a COMPLEX component.~:@>"
+ typespec)))))))
(let ((ctype (specifier-type typespec)))
- (cond
- ((eq ctype *empty-type*) *empty-type*)
- ((eq ctype *universal-type*) (not-real))
- ((typep ctype 'numeric-type) (complex1 ctype))
- ((typep ctype 'union-type)
- (apply #'type-union
- ;; FIXME: This code could suffer from (admittedly
- ;; very obscure) cases of bug 145 e.g. when TYPE
- ;; is
- ;; (OR (AND INTEGER (SATISFIES ODDP))
- ;; (AND FLOAT (SATISFIES FOO))
- ;; and not even report the problem very well.
- (mapcar #'complex1 (union-type-types ctype))))
- ((typep ctype 'member-type)
- (apply #'type-union
- (mapcar (lambda (x) (complex1 (ctype-of x)))
- (member-type-members ctype))))
- ((and (typep ctype 'intersection-type)
- ;; FIXME: This is very much a
- ;; not-quite-worst-effort, but we are required to do
- ;; something here because of our representation of
- ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
- ;; allow users to ask about (COMPLEX RATIO). This
- ;; will of course fail to work right on such types
- ;; as (AND INTEGER (SATISFIES ZEROP))...
- (let ((numbers (remove-if-not
- #'numeric-type-p
- (intersection-type-types ctype))))
- (and (car numbers)
- (null (cdr numbers))
- (eq (numeric-type-complexp (car numbers)) :real)
- (complex1 (car numbers))))))
- (t
- (multiple-value-bind (subtypep certainly)
- (csubtypep ctype (specifier-type 'real))
- (if (and (not subtypep) certainly)
- (not-real)
- ;; ANSI just says that TYPESPEC is any subtype of
- ;; type REAL, not necessarily a NUMERIC-TYPE. In
- ;; particular, at this point TYPESPEC could legally
- ;; be a hairy type like (AND NUMBER (SATISFIES
- ;; REALP) (SATISFIES ZEROP)), in which case we fall
- ;; through the logic above and end up here,
- ;; stumped.
- (bug "~@<(known bug #145): The type ~S is too hairy to be ~
- used for a COMPLEX component.~:@>"
- typespec)))))))))
+ (do-complex ctype)))))
;;; If X is *, return NIL, otherwise return the bound, which must be a
;;; member of TYPE or a one-element list of a member of TYPE.
(if up-p (1+ cx) (1- cx))
(if up-p (ceiling cx) (floor cx))))
(float
- (let ((res (if format (coerce cx format) (float cx))))
+ (let ((res
+ (cond
+ ((and format (subtypep format 'double-float))
+ (if (<= most-negative-double-float cx most-positive-double-float)
+ (coerce cx format)
+ nil))
+ (t
+ (if (<= most-negative-single-float cx most-positive-single-float)
+ ;; FIXME: bug #389
+ (coerce cx (or format 'single-float))
+ nil)))))
(if (consp x) (list res) res)))))
nil))
(!define-type-class array)
-;;; What this does depends on the setting of the
-;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized
-;;; element type, otherwise return the original element type.
-(defun specialized-element-type-maybe (type)
- (declare (type array-type type))
- (if *use-implementation-types*
- (array-type-specialized-element-type type)
- (array-type-element-type type)))
-
(!define-type-method (array :simple-=) (type1 type2)
- (if (or (unknown-type-p (array-type-element-type type1))
- (unknown-type-p (array-type-element-type type2)))
- (multiple-value-bind (equalp certainp)
- (type= (array-type-element-type type1)
- (array-type-element-type type2))
- ;; By its nature, the call to TYPE= should never return NIL,
- ;; T, as we don't know what the UNKNOWN-TYPE will grow up to
- ;; be. -- CSR, 2002-08-19
- (aver (not (and (not equalp) certainp)))
- (values equalp certainp))
- (values (and (equal (array-type-dimensions type1)
+ (cond ((not (and (equal (array-type-dimensions type1)
(array-type-dimensions type2))
(eq (array-type-complexp type1)
- (array-type-complexp type2))
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
- t)))
+ (array-type-complexp type2))))
+ (values nil t))
+ ((or (unknown-type-p (array-type-element-type type1))
+ (unknown-type-p (array-type-element-type type2)))
+ (type= (array-type-element-type type1)
+ (array-type-element-type type2)))
+ (t
+ (values (type= (array-type-specialized-element-type type1)
+ (array-type-specialized-element-type type2))
+ t))))
(!define-type-method (array :negate) (type)
;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
(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))
;; if the TYPE2 element type is wild.
((eq (array-type-element-type type2) *wild-type*)
(values t t))
- (;; Since we didn't match any of the special cases above, we
- ;; can't give a good answer unless both the element types
- ;; have been defined.
+ (;; Since we didn't match any of the special cases above, if
+ ;; either element type is unknown we can only give a good
+ ;; answer if they are the same.
(or (unknown-type-p (array-type-element-type type1))
(unknown-type-p (array-type-element-type type2)))
- (values nil nil))
+ (if (type= (array-type-element-type type1)
+ (array-type-element-type type2))
+ (values t t)
+ (values nil nil)))
(;; Otherwise, the subtype relationship holds iff the
;; types are equal, and they're equal iff the specialized
;; element types are identical.
t
- (values (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2))
+ (values (type= (array-type-specialized-element-type type1)
+ (array-type-specialized-element-type type2))
t)))))
-;;; FIXME: is this dead?
(!define-superclasses array
- ((base-string base-string)
- (vector vector)
- (array))
+ ((vector vector) (array))
!cold-init-forms)
(defun array-types-intersect (type1 type2)
;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
((or (eq (array-type-specialized-element-type type1) *wild-type*)
(eq (array-type-specialized-element-type type2) *wild-type*)
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
+ (type= (array-type-specialized-element-type type1)
+ (array-type-specialized-element-type type2)))
(values t t))
(t
(values nil t)))))
+(!define-type-method (array :simple-union2) (type1 type2)
+ (let* ((dims1 (array-type-dimensions type1))
+ (dims2 (array-type-dimensions type2))
+ (complexp1 (array-type-complexp type1))
+ (complexp2 (array-type-complexp type2))
+ (eltype1 (array-type-element-type type1))
+ (eltype2 (array-type-element-type type2))
+ (stype1 (array-type-specialized-element-type type1))
+ (stype2 (array-type-specialized-element-type type2))
+ (wild1 (eq eltype1 *wild-type*))
+ (wild2 (eq eltype2 *wild-type*))
+ (e2 nil))
+ (when (or wild1 wild2
+ (and (or (setf e2 (csubtypep eltype1 eltype2))
+ (csubtypep eltype2 eltype1))
+ (type= stype1 stype2)))
+ (make-array-type
+ :dimensions (cond ((or (eq dims1 '*) (eq dims2 '*))
+ '*)
+ ((equal dims1 dims2)
+ dims1)
+ ((= (length dims1) (length dims2))
+ (mapcar (lambda (x y) (if (eq x y) x '*))
+ dims1 dims2))
+ (t
+ '*))
+ :complexp (if (eq complexp1 complexp2) complexp1 :maybe)
+ :element-type (if (or wild2 e2) eltype2 eltype1)
+ :specialized-element-type (if wild2 stype2 stype1)))))
+
(!define-type-method (array :simple-intersection2) (type1 type2)
(declare (type array-type type1 type2))
(if (array-types-intersect type1 type2)
(complexp1 (array-type-complexp type1))
(complexp2 (array-type-complexp type2))
(eltype1 (array-type-element-type type1))
- (eltype2 (array-type-element-type type2)))
- (specialize-array-type
- (make-array-type
- :dimensions (cond ((eq dims1 '*) dims2)
- ((eq dims2 '*) dims1)
- (t
- (mapcar (lambda (x y) (if (eq x '*) y x))
- dims1 dims2)))
- :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
- :element-type (cond
- ((eq eltype1 *wild-type*) eltype2)
- ((eq eltype2 *wild-type*) eltype1)
- (t (type-intersection eltype1 eltype2))))))
+ (eltype2 (array-type-element-type type2))
+ (stype1 (array-type-specialized-element-type type1))
+ (stype2 (array-type-specialized-element-type type2)))
+ (flet ((intersect ()
+ (make-array-type
+ :dimensions (cond ((eq dims1 '*) dims2)
+ ((eq dims2 '*) dims1)
+ (t
+ (mapcar (lambda (x y) (if (eq x '*) y x))
+ dims1 dims2)))
+ :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
+ :element-type (cond
+ ((eq eltype1 *wild-type*) eltype2)
+ ((eq eltype2 *wild-type*) eltype1)
+ (t (type-intersection eltype1 eltype2))))))
+ (if (or (eq stype1 *wild-type*) (eq stype2 *wild-type*))
+ (specialize-array-type (intersect))
+ (let ((type (intersect)))
+ (aver (type= stype1 stype2))
+ (setf (array-type-specialized-element-type type) stype1)
+ type))))
*empty-type*))
;;; Check a supplied dimension list to determine whether it is legal,
(!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)
((type= type (specifier-type 'standard-char)) 'standard-char)
(t `(member ,@members)))))
+(!define-type-method (member :singleton-p) (type)
+ (if (eql 1 (member-type-size type))
+ (values t (first (member-type-members type)))
+ (values nil nil)))
+
(!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)
;;; mechanically unparsed.
(!define-type-method (intersection :unparse) (type)
(declare (type ctype type))
- (or (find type '(ratio keyword) :key #'specifier-type :test #'type=)
+ (or (find type '(ratio keyword compiled-function) :key #'specifier-type :test #'type=)
`(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
;;; shared machinery for type equality: true if every type in the set
:high (if (null (numeric-type-high type1))
nil
(list (1+ (numeric-type-high type1)))))))
- (type-union type1
- (apply #'type-intersection
- (remove (specifier-type '(not integer))
- (intersection-type-types type2)
- :test #'type=))))
+ (let* ((intersected (intersection-type-types type2))
+ (remaining (remove (specifier-type '(not integer))
+ intersected
+ :test #'type=)))
+ (and (not (equal intersected remaining))
+ (type-union type1 (apply #'type-intersection remaining)))))
(t
(let ((accumulator *universal-type*))
(do ((t2s (intersection-type-types type2) (cdr t2s)))
(union-complex-subtypep-arg1 type1 type2))
(defun union-complex-subtypep-arg2 (type1 type2)
+ ;; At this stage, we know that type2 is a union type and type1
+ ;; isn't. We might as well check this, though:
+ (aver (union-type-p type2))
+ (aver (not (union-type-p type1)))
+ ;; was: (any/type #'csubtypep type1 (union-type-types type2)), which
+ ;; turns out to be too restrictive, causing bug 91.
+ ;;
+ ;; the following reimplementation might look dodgy. It is dodgy. It
+ ;; depends on the union :complex-= method not doing very much work
+ ;; -- certainly, not using subtypep. Reasoning:
+ ;;
+ ;; A is a subset of (B1 u B2)
+ ;; <=> A n (B1 u B2) = A
+ ;; <=> (A n B1) u (A n B2) = A
+ ;;
+ ;; But, we have to be careful not to delegate this type= to
+ ;; something that could invoke subtypep, which might get us back
+ ;; here -> stack explosion. We therefore ensure that the second type
+ ;; (which is the one that's dispatched on) is either a union type
+ ;; (where we've ensured that the complex-= method will not call
+ ;; subtypep) or something with no union types involved, in which
+ ;; case we'll never come back here.
+ ;;
+ ;; If we don't do this, then e.g.
+ ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
+ ;; would loop infinitely, as the member :complex-= method is
+ ;; implemented in terms of subtypep.
+ ;;
+ ;; Ouch. - CSR, 2002-04-10
(multiple-value-bind (sub-value sub-certain?)
- ;; was: (any/type #'csubtypep type1 (union-type-types type2)),
- ;; which turns out to be too restrictive, causing bug 91.
- ;;
- ;; the following reimplementation might look dodgy. It is
- ;; dodgy. It depends on the union :complex-= method not doing
- ;; very much work -- certainly, not using subtypep. Reasoning:
- (progn
- ;; At this stage, we know that type2 is a union type and type1
- ;; isn't. We might as well check this, though:
- (aver (union-type-p type2))
- (aver (not (union-type-p type1)))
- ;; A is a subset of (B1 u B2)
- ;; <=> A n (B1 u B2) = A
- ;; <=> (A n B1) u (A n B2) = A
- ;;
- ;; But, we have to be careful not to delegate this type= to
- ;; something that could invoke subtypep, which might get us
- ;; back here -> stack explosion. We therefore ensure that the
- ;; second type (which is the one that's dispatched on) is
- ;; either a union type (where we've ensured that the complex-=
- ;; method will not call subtypep) or something with no union
- ;; types involved, in which case we'll never come back here.
- ;;
- ;; If we don't do this, then e.g.
- ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
- ;; would loop infinitely, as the member :complex-= method is
- ;; implemented in terms of subtypep.
- ;;
- ;; Ouch. - CSR, 2002-04-10
- (type= type1
- (apply #'type-union
- (mapcar (lambda (x) (type-intersection type1 x))
- (union-type-types type2)))))
+ (type= type1
+ (apply #'type-union
+ (mapcar (lambda (x) (type-intersection type1 x))
+ (union-type-types type2))))
(if sub-certain?
(values sub-value sub-certain?)
;; The ANY/TYPE expression above is a sufficient condition for
(!define-type-method (cons :simple-=) (type1 type2)
(declare (type cons-type type1 type2))
- (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
- (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
+ (multiple-value-bind (car-match car-win)
+ (type= (cons-type-car-type type1) (cons-type-car-type type2))
+ (multiple-value-bind (cdr-match cdr-win)
+ (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+ (cond ((and car-match cdr-match)
+ (aver (and car-win cdr-win))
+ (values t t))
+ (t
+ (values nil
+ ;; FIXME: Ideally we would like to detect and handle
+ ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T
+ ;; but just returning a secondary true on (and car-win cdr-win)
+ ;; unfortunately breaks other things. --NS 2006-08-16
+ (and (or (and (not car-match) car-win)
+ (and (not cdr-match) cdr-win))
+ (not (and (cons-type-might-be-empty-type type1)
+ (cons-type-might-be-empty-type type2))))))))))
(!define-type-method (cons :simple-subtypep) (type1 type2)
(declare (type cons-type type1 type2))
(csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
(if (and val-car val-cdr)
(values t (and win-car win-cdr))
- (values nil (or win-car win-cdr))))))
+ (values nil (or (and (not val-car) win-car)
+ (and (not val-cdr) win-cdr)))))))
;;; Give up if a precise type is not possible, to avoid returning
;;; overly general types.
;; more general case of the above, but harder to compute
((progn
(setf car-not1 (type-negation car-type1))
- (not (csubtypep car-type2 car-not1)))
+ (multiple-value-bind (yes win)
+ (csubtypep car-type2 car-not1)
+ (and (not yes) win)))
(frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
((progn
(setf car-not2 (type-negation car-type2))
- (not (csubtypep car-type1 car-not2)))
+ (multiple-value-bind (yes win)
+ (csubtypep car-type1 car-not2)
+ (and (not yes) win)))
(frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))
;; Don't put these in -- consider the effect of taking the
;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
(type-intersection (cons-type-car-type type1)
(cons-type-car-type type2))
cdr-int2)))))
+
+(!define-superclasses cons ((cons)) !cold-init-forms)
\f
;;;; CHARACTER-SET types
(!define-type-method (character-set :negate) (type)
(let ((pairs (character-set-type-pairs type)))
(if (and (= (length pairs) 1)
- (= (caar pairs) 0)
- (= (cdar pairs) (1- sb!xc:char-code-limit)))
- (make-negation-type :type type)
- (let ((not-character
- (make-negation-type
- :type (make-character-set-type
- :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
- (type-union
- not-character
- (make-character-set-type
- :pairs (let (not-pairs)
- (when (> (caar pairs) 0)
- (push (cons 0 (1- (caar pairs))) not-pairs))
- (do* ((tail pairs (cdr tail))
- (high1 (cdar tail))
- (low2 (caadr tail)))
- ((null (cdr tail))
- (when (< (cdar tail) (1- sb!xc:char-code-limit))
- (push (cons (1+ (cdar tail))
- (1- sb!xc:char-code-limit))
- not-pairs))
- (nreverse not-pairs))
- (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
+ (= (caar pairs) 0)
+ (= (cdar pairs) (1- sb!xc:char-code-limit)))
+ (make-negation-type :type type)
+ (let ((not-character
+ (make-negation-type
+ :type (make-character-set-type
+ :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
+ (type-union
+ not-character
+ (make-character-set-type
+ :pairs (let (not-pairs)
+ (when (> (caar pairs) 0)
+ (push (cons 0 (1- (caar pairs))) not-pairs))
+ (do* ((tail pairs (cdr tail))
+ (high1 (cdar tail) (cdar tail))
+ (low2 (caadr tail) (caadr tail)))
+ ((null (cdr tail))
+ (when (< (cdar tail) (1- sb!xc:char-code-limit))
+ (push (cons (1+ (cdar tail))
+ (1- sb!xc:char-code-limit))
+ not-pairs))
+ (nreverse not-pairs))
+ (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
(!define-type-method (character-set :unparse) (type)
(cond
((type= type (specifier-type 'base-char)) 'base-char)
((type= type (specifier-type 'extended-char)) 'extended-char)
((type= type (specifier-type 'standard-char)) 'standard-char)
- (t (let ((pairs (character-set-type-pairs type)))
- `(member ,@(loop for (low . high) in pairs
+ (t
+ ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there
+ ;; are at most as many characters than there are character code ranges.
+ (let* ((pairs (character-set-type-pairs type))
+ (count (length pairs))
+ (chars (loop named outer
+ for (low . high) in pairs
nconc (loop for code from low upto high
- collect (sb!xc:code-char code))))))))
+ collect (sb!xc:code-char code)
+ when (minusp (decf count))
+ do (return-from outer t)))))
+ (if (eq chars t)
+ `(character-set ,pairs)
+ `(member ,@chars))))))
+
+(!define-type-method (character-set :singleton-p) (type)
+ (let* ((pairs (character-set-type-pairs type))
+ (pair (first pairs)))
+ (if (and (typep pairs '(cons t null))
+ (eql (car pair) (cdr pair)))
+ (values t (code-char (car pair)))
+ (values nil nil))))
(!define-type-method (character-set :simple-=) (type1 type2)
(let ((pairs1 (character-set-type-pairs type1))
(!define-type-method (character-set :simple-intersection2) (type1 type2)
;; KLUDGE: brute force.
+#|
(let (pairs)
(dolist (pair1 (character-set-type-pairs type1)
(make-character-set-type
((<= (car pair1) (car pair2) (cdr pair1))
(push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs))
((<= (car pair2) (car pair1) (cdr pair2))
- (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs)))))))
+ (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs))))))
+|#
+ (make-character-set-type
+ :pairs (intersect-type-pairs
+ (character-set-type-pairs type1)
+ (character-set-type-pairs type2))))
+
+;;;
+;;; Intersect two ordered lists of pairs
+;;; Each list is of the form ((start1 . end1) ... (startn . endn)),
+;;; where start1 <= end1 < start2 <= end2 < ... < startn <= endn.
+;;; Each pair represents the integer interval start..end.
+;;;
+(defun intersect-type-pairs (alist1 alist2)
+ (if (and alist1 alist2)
+ (let ((res nil)
+ (pair1 (pop alist1))
+ (pair2 (pop alist2)))
+ (loop
+ (when (> (car pair1) (car pair2))
+ (rotatef pair1 pair2)
+ (rotatef alist1 alist2))
+ (let ((pair1-cdr (cdr pair1)))
+ (cond
+ ((> (car pair2) pair1-cdr)
+ ;; No over lap -- discard pair1
+ (unless alist1 (return))
+ (setq pair1 (pop alist1)))
+ ((<= (cdr pair2) pair1-cdr)
+ (push (cons (car pair2) (cdr pair2)) res)
+ (cond
+ ((= (cdr pair2) pair1-cdr)
+ (unless alist1 (return))
+ (unless alist2 (return))
+ (setq pair1 (pop alist1)
+ pair2 (pop alist2)))
+ (t ;; (< (cdr pair2) pair1-cdr)
+ (unless alist2 (return))
+ (setq pair1 (cons (1+ (cdr pair2)) pair1-cdr))
+ (setq pair2 (pop alist2)))))
+ (t ;; (> (cdr pair2) (cdr pair1))
+ (push (cons (car pair2) pair1-cdr) res)
+ (unless alist1 (return))
+ (setq pair2 (cons (1+ pair1-cdr) (cdr pair2)))
+ (setq pair1 (pop alist1))))))
+ (nreverse res))
+ nil))
+
\f
;;; Return the type that describes all objects that are in X but not
;;; in Y. If we can't determine this type, then return NIL.
;;; 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 '*))
*wild-type*
(specifier-type element-type)))))
\f
+;;;; SIMD-PACK types
+#!+sb-simd-pack
+(progn
+ (!define-type-class simd-pack)
+
+ (!def-type-translator simd-pack (&optional (element-type-spec '*))
+ (if (eql element-type-spec '*)
+ (%make-simd-pack-type *simd-pack-element-types*)
+ (make-simd-pack-type (single-value-specifier-type element-type-spec))))
+
+ (!define-type-method (simd-pack :negate) (type)
+ (let ((remaining (set-difference *simd-pack-element-types*
+ (simd-pack-type-element-type type)))
+ (not-simd-pack (make-negation-type :type (specifier-type 'simd-pack))))
+ (if remaining
+ (type-union not-simd-pack (%make-simd-pack-type remaining))
+ not-simd-pack)))
+
+ (!define-type-method (simd-pack :unparse) (type)
+ (let ((eltypes (simd-pack-type-element-type type)))
+ (cond ((equal eltypes *simd-pack-element-types*)
+ 'simd-pack)
+ ((= 1 (length eltypes))
+ `(simd-pack ,(first eltypes)))
+ (t
+ `(or ,@(mapcar (lambda (eltype)
+ `(simd-pack ,eltype))
+ eltypes))))))
+
+ (!define-type-method (simd-pack :simple-=) (type1 type2)
+ (declare (type simd-pack-type type1 type2))
+ (null (set-exclusive-or (simd-pack-type-element-type type1)
+ (simd-pack-type-element-type type2))))
+
+ (!define-type-method (simd-pack :simple-subtypep) (type1 type2)
+ (declare (type simd-pack-type type1 type2))
+ (subsetp (simd-pack-type-element-type type1)
+ (simd-pack-type-element-type type2)))
+
+ (!define-type-method (simd-pack :simple-union2) (type1 type2)
+ (declare (type simd-pack-type type1 type2))
+ (%make-simd-pack-type (union (simd-pack-type-element-type type1)
+ (simd-pack-type-element-type type2))))
+
+ (!define-type-method (simd-pack :simple-intersection2) (type1 type2)
+ (declare (type simd-pack-type type1 type2))
+ (let ((intersection (intersection (simd-pack-type-element-type type1)
+ (simd-pack-type-element-type type2))))
+ (if intersection
+ (%make-simd-pack-type intersection)
+ *empty-type*)))
+
+ (!define-superclasses simd-pack ((simd-pack)) !cold-init-forms))
+\f
;;;; utilities shared between cross-compiler and target system
;;; Does the type derived from compilation of an actual function
projects / sbcl.git / blobdiff