;;; There are all sorts of nasty problems with open bounds on FLOAT
;;; types (and probably FLOAT types in general.)
+;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
+;;; compiler warnings can be emitted as appropriate.
+(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
(return (values nil t))))))
(!define-type-method (values :simple-=) (type1 type2)
- (let ((rest1 (args-type-rest type1))
- (rest2 (args-type-rest type2)))
- (cond ((and rest1 rest2 (type/= rest1 rest2))
- (type= rest1 rest2))
- ((or rest1 rest2)
- (values nil t))
- (t
- (multiple-value-bind (req-val req-win)
- (type=-list (values-type-required type1)
- (values-type-required type2))
- (multiple-value-bind (opt-val opt-win)
- (type=-list (values-type-optional type1)
- (values-type-optional type2))
- (values (and req-val opt-val) (and req-win opt-win))))))))
+ (type=-args type1 type2))
(!define-type-class function)
((fun-type-wild-args type1)
(cond ((fun-type-keyp type2) (values nil nil))
((not (fun-type-rest type2)) (values nil t))
- ((not (null (fun-type-required type2))) (values nil t))
- (t (and/type (type= *universal-type* (fun-type-rest type2))
- (every/type #'type= *universal-type*
- (fun-type-optional type2))))))
+ ((not (null (fun-type-required type2)))
+ (values nil t))
+ (t (and/type (type= *universal-type*
+ (fun-type-rest type2))
+ (every/type #'type=
+ *universal-type*
+ (fun-type-optional
+ type2))))))
((not (and (fun-type-simple-p type1)
(fun-type-simple-p type2)))
(values nil nil))
(cond ((or (> max1 max2) (< min1 min2))
(values nil t))
((and (= min1 min2) (= max1 max2))
- (and/type (every-csubtypep (fun-type-required type1)
- (fun-type-required type2))
- (every-csubtypep (fun-type-optional type1)
- (fun-type-optional type2))))
+ (and/type (every-csubtypep
+ (fun-type-required type1)
+ (fun-type-required type2))
+ (every-csubtypep
+ (fun-type-optional type1)
+ (fun-type-optional type2))))
(t (every-csubtypep
(concatenate 'list
(fun-type-required type1)
(declare (ignore type1 type2))
(specifier-type 'function))
(!define-type-method (function :simple-intersection2) (type1 type2)
- (declare (ignore type1 type2))
- (specifier-type 'function))
+ (let ((ftype (specifier-type 'function)))
+ (cond ((eq type1 ftype) type2)
+ ((eq type2 ftype) type1)
+ (t (let ((rtype (values-type-intersection (fun-type-returns type1)
+ (fun-type-returns type2))))
+ (flet ((change-returns (ftype rtype)
+ (declare (type fun-type ftype) (type ctype rtype))
+ (make-fun-type :required (fun-type-required ftype)
+ :optional (fun-type-optional ftype)
+ :keyp (fun-type-keyp ftype)
+ :keywords (fun-type-keywords ftype)
+ :allowp (fun-type-allowp ftype)
+ :returns rtype)))
+ (cond
+ ((fun-type-wild-args type1)
+ (if (fun-type-wild-args type2)
+ (make-fun-type :wild-args t
+ :returns rtype)
+ (change-returns type2 rtype)))
+ ((fun-type-wild-args type2)
+ (change-returns type1 rtype))
+ (t (multiple-value-bind (req opt rest)
+ (args-type-op type1 type2 #'type-intersection #'max)
+ (make-fun-type :required req
+ :optional opt
+ :rest rest
+ ;; FIXME: :keys
+ :allowp (and (fun-type-allowp type1)
+ (fun-type-allowp type2))
+ :returns rtype))))))))))
;;; The union or intersection of a subclass of FUNCTION with a
;;; FUNCTION type is somewhat complicated.
(values nil t))
((eq (fun-type-wild-args type1) t)
(values t t))
- (t (and/type
- (cond ((null (fun-type-rest type1))
- (values (null (fun-type-rest type2)) t))
- ((null (fun-type-rest type2))
- (values nil t))
- (t
- (compare type= rest)))
- (labels ((type-list-= (l1 l2)
- (cond ((null l1)
- (values (null l2) t))
- ((null l2)
- (values nil t))
- (t (multiple-value-bind (res winp)
- (type= (first l1) (first l2))
- (cond ((not winp)
- (values nil nil))
- ((not res)
- (values nil t))
- (t
- (type-list-= (rest l1)
- (rest l2)))))))))
- (and/type (and/type (compare type-list-= required)
- (compare type-list-= optional))
- (if (or (fun-type-keyp type1) (fun-type-keyp type2))
- (values nil nil)
- (values t t))))))))))
+ (t (type=-args type1 type2))))))
(!define-type-class constant :inherits values)
(cond ((args-type-rest type))
(t default-type)))))
-;;; If COUNT values are supplied, which types should they have?
-(defun values-type-start (type count)
+;;; types of values in (the <type> (values o_1 ... o_n))
+(defun values-type-out (type count)
(declare (type ctype type) (type unsigned-byte count))
(if (eq type *wild-type*)
(make-list count :initial-element *universal-type*)
do (res rest))))
(res))))
+;;; types of variable in (m-v-bind (v_1 ... v_n) (the <type> ...
+(defun values-type-in (type count)
+ (declare (type ctype type) (type unsigned-byte count))
+ (if (eq type *wild-type*)
+ (make-list count :initial-element *universal-type*)
+ (collect ((res))
+ (let ((null-type (specifier-type 'null)))
+ (loop for type in (values-type-required type)
+ while (plusp count)
+ do (decf count)
+ do (res type))
+ (loop for type in (values-type-optional type)
+ while (plusp count)
+ do (decf count)
+ do (res (type-union type null-type)))
+ (when (plusp count)
+ (loop with rest = (acond ((values-type-rest type)
+ (type-union it null-type))
+ (t null-type))
+ repeat count
+ do (res rest))))
+ (res))))
+
;;; Return a list of OPERATION applied to the types in TYPES1 and
;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
;;; than TYPES2. The second value is T if OPERATION always returned a
(length (args-type-required type2))))
(required (subseq res 0 req))
(opt (subseq res req)))
- (values (make-values-type
- :required required
- :optional opt
- :rest rest)
+ (values required opt rest
(and rest-exact res-exact))))))))
+(defun values-type-op (type1 type2 operation nreq)
+ (multiple-value-bind (required optional rest exactp)
+ (args-type-op type1 type2 operation nreq)
+ (values (make-values-type :required required
+ :optional optional
+ :rest rest)
+ exactp)))
+
+(defun type=-args (type1 type2)
+ (macrolet ((compare (comparator field)
+ (let ((reader (symbolicate '#:args-type- field)))
+ `(,comparator (,reader type1) (,reader type2)))))
+ (and/type
+ (cond ((null (args-type-rest type1))
+ (values (null (args-type-rest type2)) t))
+ ((null (args-type-rest type2))
+ (values nil t))
+ (t
+ (compare type= rest)))
+ (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 t t))))))
+
;;; Do a union or intersection operation on types that might be values
;;; types. The result is optimized for utility rather than exactness,
;;; but it is guaranteed that it will be no smaller (more restrictive)
((eq type1 *empty-type*) type2)
((eq type2 *empty-type*) type1)
(t
- (values (args-type-op type1 type2 #'type-union #'min)))))
+ (values (values-type-op type1 type2 #'type-union #'min)))))
(defun-cached (values-type-intersection :hash-function type-cache-hash
:hash-bits 8
- :values 2
- :default (values nil :empty)
+ :default (values nil)
:init-wrapper !cold-init-forms)
((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
- (cond ((eq type1 *wild-type*) (values (coerce-to-values type2) t))
+ (cond ((eq type1 *wild-type*)
+ (coerce-to-values type2))
((or (eq type2 *wild-type*) (eq type2 *universal-type*))
- (values type1 t))
+ type1)
((or (eq type1 *empty-type*) (eq type2 *empty-type*))
*empty-type*)
((and (not (values-type-p type2))
(values-type-required type1))
(let ((req1 (values-type-required type1)))
- (make-values-type :required (cons (type-intersection (first req1) type2)
- (rest req1))
- :optional (values-type-optional type1)
- :rest (values-type-rest type1)
- :allowp (values-type-allowp type1))))
+ (make-values-type :required (cons (type-intersection (first req1) type2)
+ (rest req1))
+ :optional (values-type-optional type1)
+ :rest (values-type-rest type1)
+ :allowp (values-type-allowp type1))))
(t
- (args-type-op type1 (coerce-to-values type2)
- #'type-intersection
- #'max))))
+ (values (values-type-op type1 (coerce-to-values type2)
+ #'type-intersection
+ #'max)))))
;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
;;; works on VALUES types. Note that due to the semantics of
((or (eq type1 *wild-type*) (eq type2 *wild-type*))
(values t t))
(t
- (multiple-value-bind (res win) (values-type-intersection type1 type2)
+ (let ((res (values-type-intersection type1 type2)))
(values (not (eq res *empty-type*))
- win)))))
+ t)))))
;;; a SUBTYPEP-like operation that can be used on any types, including
;;; VALUES types
;;;; These are fully general operations on CTYPEs: they'll always
;;;; return a CTYPE representing the result.
-;;; shared logic for unions and intersections: Return a vector of
+;;; shared logic for unions and intersections: Return a list of
;;; types representing the same types as INPUT-TYPES, but with
;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
;;; component types, and with any SIMPLY2 simplifications applied.
-(declaim (inline simplified-compound-types))
-(defun simplified-compound-types (input-types %compound-type-p simplify2)
- (declare (function %compound-type-p simplify2))
- (let ((types (make-array (length input-types)
- :fill-pointer 0
- :adjustable t
- :element-type 'ctype)))
- (labels ((accumulate-compound-type (type)
- (if (funcall %compound-type-p type)
- (dolist (type (compound-type-types type))
- (accumulate1-compound-type type))
- (accumulate1-compound-type type)))
- (accumulate1-compound-type (type)
- (declare (type ctype type))
- ;; Any input object satisfying %COMPOUND-TYPE-P should've been
- ;; broken into components before it reached us.
- (aver (not (funcall %compound-type-p type)))
- (dotimes (i (length types) (vector-push-extend type types))
- (let ((simplified2 (funcall simplify2 type (aref types i))))
- (when simplified2
- ;; Discard the old (AREF TYPES I).
- (setf (aref types i) (vector-pop types))
- ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
- ;; (Note that the tail recursion is indirect: we go through
- ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
- ;; handled properly if it satisfies %COMPOUND-TYPE-P.)
- (return (accumulate-compound-type simplified2)))))))
- (dolist (input-type input-types)
- (accumulate-compound-type input-type)))
- types))
-
-;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
-;;; object whose components are the types in TYPES, or skip to special
-;;; cases when TYPES is short.
-(defun make-probably-compound-type (constructor types enumerable identity)
- (declare (type function constructor))
- (declare (type (vector ctype) types))
- (declare (type ctype identity))
- (case (length types)
- (0 identity)
- (1 (aref types 0))
- (t (funcall constructor
- enumerable
- ;; FIXME: This should be just (COERCE TYPES 'LIST), but as
- ;; of sbcl-0.6.11.17 the COERCE optimizer is really
- ;; brain-dead, so that would generate a full call to
- ;; SPECIFIER-TYPE at runtime, so we get into bootstrap
- ;; problems in cold init because 'LIST is a compound
- ;; type, so we need to MAKE-PROBABLY-COMPOUND-TYPE
- ;; before we know what 'LIST is. Once the COERCE
- ;; optimizer is less brain-dead, we can make this
- ;; (COERCE TYPES 'LIST) again.
- #+sb-xc-host (coerce types 'list)
- #-sb-xc-host (coerce-to-list types)))))
-
+(macrolet
+ ((def (name compound-type-p simplify2)
+ `(defun ,name (types)
+ (when types
+ (multiple-value-bind (first rest)
+ (if (,compound-type-p (car types))
+ (values (car (compound-type-types (car types)))
+ (append (cdr (compound-type-types (car types)))
+ (cdr types)))
+ (values (car types) (cdr types)))
+ (let ((rest (,name rest)) u)
+ (dolist (r rest (cons first rest))
+ (when (setq u (,simplify2 first r))
+ (return (,name (nsubstitute u r rest)))))))))))
+ (def simplify-intersections intersection-type-p type-intersection2)
+ (def simplify-unions union-type-p type-union2))
+
(defun maybe-distribute-one-union (union-type types)
(let* ((intersection (apply #'type-intersection types))
(union (mapcar (lambda (x) (type-intersection x intersection))
:hash-function (lambda (x)
(logand (sxhash x) #xff)))
((input-types equal))
- (let ((simplified-types (simplified-compound-types input-types
- #'intersection-type-p
- #'type-intersection2)))
- (declare (type (vector ctype) simplified-types))
+ (let ((simplified-types (simplify-intersections input-types)))
+ (declare (type list simplified-types))
;; We want to have a canonical representation of types (or failing
;; that, punt to HAIRY-TYPE). Canonical representation would have
;; intersections inside unions but not vice versa, since you can
;; to end up with unreasonably huge type expressions. So instead
;; we try to generate a simple type by distributing the union; if
;; the type can't be made simple, we punt to HAIRY-TYPE.
- (if (and (> (length simplified-types) 1)
- (some #'union-type-p simplified-types))
+ (if (and (cdr simplified-types) (some #'union-type-p simplified-types))
(let* ((first-union (find-if #'union-type-p simplified-types))
(other-types (coerce (remove first-union simplified-types)
'list))
:specifier `(and ,@(map 'list
#'type-specifier
simplified-types)))))
- (make-probably-compound-type #'%make-intersection-type
- simplified-types
- (some #'type-enumerable
- simplified-types)
- *universal-type*))))
+ (cond
+ ((null simplified-types) *universal-type*)
+ ((null (cdr simplified-types)) (car simplified-types))
+ (t (%make-intersection-type
+ (some #'type-enumerable simplified-types)
+ simplified-types))))))
(defun type-union (&rest input-types)
(%type-union input-types))
:hash-function (lambda (x)
(logand (sxhash x) #xff)))
((input-types equal))
- (let ((simplified-types (simplified-compound-types input-types
- #'union-type-p
- #'type-union2)))
- (make-probably-compound-type #'make-union-type
- simplified-types
- (every #'type-enumerable simplified-types)
- *empty-type*)))
+ (let ((simplified-types (simplify-unions input-types)))
+ (cond
+ ((null simplified-types) *empty-type*)
+ ((null (cdr simplified-types)) (car simplified-types))
+ (t (make-union-type
+ (every #'type-enumerable simplified-types)
+ simplified-types)))))
\f
;;;; built-in types
(values nil nil))
(!define-type-method (hairy :complex-=) (type1 type2)
- (declare (ignore type1 type2))
- (values nil nil))
+ (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)))
(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
(type1 type2)
(!define-type-class number)
+(declaim (inline numeric-type-equal))
+(defun numeric-type-equal (type1 type2)
+ (and (eq (numeric-type-class type1) (numeric-type-class type2))
+ (eq (numeric-type-format type1) (numeric-type-format type2))
+ (eq (numeric-type-complexp type1) (numeric-type-complexp type2))))
+
(!define-type-method (number :simple-=) (type1 type2)
(values
- (and (eq (numeric-type-class type1) (numeric-type-class type2))
- (eq (numeric-type-format type1) (numeric-type-format type2))
- (eq (numeric-type-complexp type1) (numeric-type-complexp type2))
+ (and (numeric-type-equal type1 type2)
(equalp (numeric-type-low type1) (numeric-type-low type2))
(equalp (numeric-type-high type1) (numeric-type-high type2)))
t))
((consp low-bound)
(let ((low-value (car low-bound)))
(or (eql low-value high-bound)
- (and (eql low-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0))
- (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
- (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0))
- (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
+ (and (eql low-value
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero)))
+ (eql high-bound 0f0))
+ (and (eql low-value 0f0)
+ (eql high-bound
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero))))
+ (and (eql low-value
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))
+ (eql high-bound 0d0))
+ (and (eql low-value 0d0)
+ (eql high-bound
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))))))
((consp high-bound)
(let ((high-value (car high-bound)))
(or (eql high-value low-bound)
- (and (eql high-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0))
- (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
- (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0))
- (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
+ (and (eql high-value
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero)))
+ (eql low-bound 0f0))
+ (and (eql high-value 0f0)
+ (eql low-bound
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero))))
+ (and (eql high-value
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))
+ (eql low-bound 0d0))
+ (and (eql high-value 0d0)
+ (eql low-bound
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))))))
((and (eq (numeric-type-class low) 'integer)
(eq (numeric-type-class high) 'integer))
(eql (1+ low-bound) high-bound))
(specialized-element-type-maybe type2))
t)))))
+;;; FIXME: is this dead?
(!define-superclasses array
((base-string base-string)
(vector vector)
(mapcar (lambda (x y) (if (eq x '*) y x))
dims1 dims2)))
:complexp (if (eq complexp1 :maybe) complexp2 complexp1)
- :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))))
+ :element-type (cond
+ ((eq eltype1 *wild-type*) eltype2)
+ ((eq eltype2 *wild-type*) eltype1)
+ (t (type-intersection eltype1 eltype2))))))
*empty-type*))
;;; Check a supplied dimension list to determine whether it is legal,