;;; 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
;;;
;;; WHEN controls when the forms are executed.
(defmacro !define-superclasses (type-class-name specs when)
- (let ((type-class (gensym "TYPE-CLASS-"))
- (info (gensym "INFO")))
+ (with-unique-names (type-class info)
`(,when
(let ((,type-class (type-class-or-lose ',type-class-name))
(,info (mapcar (lambda (spec)
(declare (ignore type1))
(error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2)))
+(!define-type-method (values :negate) (type)
+ (error "NOT VALUES too confusing on ~S" (type-specifier type)))
+
(!define-type-method (values :unparse) (type)
- (cons 'values (unparse-args-types type)))
+ (cons 'values
+ (let ((unparsed (unparse-args-types type)))
+ (if (or (values-type-optional type)
+ (values-type-rest type)
+ (values-type-allowp type))
+ unparsed
+ (nconc unparsed '(&optional))))))
;;; Return true if LIST1 and LIST2 have the same elements in the same
;;; positions according to TYPE=. We return NIL, NIL if there is an
(return (values nil t))))))
(!define-type-method (values :simple-=) (type1 type2)
- (let ((rest1 (args-type-rest type1))
- (rest2 (args-type-rest type2)))
- (cond ((or (args-type-keyp type1) (args-type-keyp type2)
- (args-type-allowp type1) (args-type-allowp type2))
- (values nil nil))
- ((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)
(defvar *unparse-fun-type-simplify*)
(!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)))
+
(!define-type-method (function :unparse) (type)
(if *unparse-fun-type-simplify*
'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.
((csubtypep type1 (specifier-type 'function)) nil)
(t :call-other-method)))
(!define-type-method (function :complex-union2) (type1 type2)
+ (declare (ignore type2))
+ ;; TYPE2 is a FUNCTION type. If TYPE1 is a classoid type naming
+ ;; FUNCTION, then it is the union of the two; otherwise, there is no
+ ;; special union.
(cond
((type= type1 (specifier-type 'function)) type1)
(t nil)))
-;;; ### Not very real, but good enough for redefining transforms
-;;; according to type:
(!define-type-method (function :simple-=) (type1 type2)
- (values (equalp type1 type2) t))
+ (macrolet ((compare (comparator field)
+ (let ((reader (symbolicate '#:fun-type- field)))
+ `(,comparator (,reader type1) (,reader type2)))))
+ (and/type (compare type= returns)
+ (cond ((neq (fun-type-wild-args type1) (fun-type-wild-args type2))
+ (values nil t))
+ ((eq (fun-type-wild-args type1) t)
+ (values t t))
+ (t (type=-args type1 type2))))))
(!define-type-class constant :inherits values)
+(!define-type-method (constant :negate) (type)
+ (error "NOT CONSTANT too confusing on ~S" (type-specifier type)))
+
(!define-type-method (constant :unparse) (type)
`(constant-arg ,(type-specifier (constant-type-type type))))
(type= (constant-type-type type1) (constant-type-type type2)))
(!def-type-translator constant-arg (type)
- (make-constant-type :type (specifier-type type)))
+ (make-constant-type :type (single-value-specifier-type type)))
;;; Return the lambda-list-like type specification corresponding
;;; to an ARGS-TYPE.
(result)))
(!def-type-translator function (&optional (args '*) (result '*))
- (make-fun-type :args args :returns (values-specifier-type result)))
+ (make-fun-type :args args
+ :returns (coerce-to-values (values-specifier-type result))))
(!def-type-translator values (&rest values)
(make-values-type :args values))
;;;; We provide a few special operations that can be meaningfully used
;;;; on VALUES types (as well as on any other type).
+(defun type-single-value-p (type)
+ (and (values-type-p type)
+ (not (values-type-rest type))
+ (null (values-type-optional type))
+ (singleton-p (values-type-required type))))
+
;;; Return the type of the first value indicated by TYPE. This is used
;;; by people who don't want to have to deal with VALUES types.
#!-sb-fluid (declaim (freeze-type values-type))
; (inline single-value-type))
(defun single-value-type (type)
(declare (type ctype type))
- (cond ((values-type-p type)
- (or (car (args-type-required type))
- (if (args-type-optional type)
- (type-union (car (args-type-optional type))
- (specifier-type 'null)))
- (args-type-rest type)
- (specifier-type 'null)))
- ((eq type *wild-type*)
- *universal-type*)
- (t
- type)))
+ (cond ((eq type *wild-type*)
+ *universal-type*)
+ ((eq type *empty-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)))))
;;; Return the minimum number of arguments that a function can be
;;; called with, and the maximum number or NIL. If not a function
;;; not fixed, then return NIL and :UNKNOWN.
(defun values-types (type)
(declare (type ctype type))
- (cond ((eq type *wild-type*)
+ (cond ((or (eq type *wild-type*) (eq type *empty-type*))
(values nil :unknown))
- ((not (values-type-p type))
- (values (list type) 1))
((or (args-type-optional type)
- (args-type-rest type)
- (args-type-keyp type)
- (args-type-allowp type))
+ (args-type-rest type))
(values nil :unknown))
(t
(let ((req (args-type-required type)))
- (values (mapcar #'single-value-type req) (length req))))))
+ (values req (length req))))))
;;; Return two values:
;;; 1. A list of all the positional (fixed and optional) types.
-;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
-;;; If no keywords or &REST, then the DEFAULT-TYPE.
+;;; 2. The &REST type (if any). If no &REST, then the DEFAULT-TYPE.
(defun values-type-types (type &optional (default-type *empty-type*))
- (declare (type values-type type))
- (values (append (args-type-required type)
- (args-type-optional type))
- (cond ((args-type-keyp type) *universal-type*)
- ((args-type-rest type))
- (t
- default-type))))
+ (declare (type ctype type))
+ (if (eq type *wild-type*)
+ (values nil *universal-type*)
+ (values (append (args-type-required type)
+ (args-type-optional type))
+ (cond ((args-type-rest type))
+ (t default-type)))))
+
+;;; 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*)
+ (collect ((res))
+ (flet ((process-types (types)
+ (loop for type in types
+ while (plusp count)
+ do (decf count)
+ do (res type))))
+ (process-types (values-type-required type))
+ (process-types (values-type-optional type))
+ (when (plusp count)
+ (loop with rest = (the ctype (values-type-rest type))
+ repeat count
+ 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
:initial-element rest2)))
exact)))
-;;; If TYPE isn't a values type, then make it into one:
-;;; <type> ==> (values type &rest t)
+;;; If TYPE isn't a values type, then make it into one.
+(defun-cached (%coerce-to-values
+ :hash-bits 8
+ :hash-function (lambda (type)
+ (logand (type-hash-value type)
+ #xff)))
+ ((type eq))
+ (cond ((multiple-value-bind (res sure)
+ (csubtypep (specifier-type 'null) type)
+ (and (not res) sure))
+ ;; FIXME: What should we do with (NOT SURE)?
+ (make-values-type :required (list type) :rest *universal-type*))
+ (t
+ (make-values-type :optional (list type) :rest *universal-type*))))
+
(defun coerce-to-values (type)
(declare (type ctype type))
- (if (values-type-p type)
- type
- (make-values-type :required (list type) :rest *universal-type*)))
+ (cond ((or (eq type *universal-type*)
+ (eq type *wild-type*))
+ *wild-type*)
+ ((values-type-p type)
+ type)
+ (t (%coerce-to-values type))))
+
+;;; Return type, corresponding to ANSI short form of VALUES type
+;;; specifier.
+(defun make-short-values-type (types)
+ (declare (list types))
+ (let ((last-required (position-if
+ (lambda (type)
+ (not/type (csubtypep (specifier-type 'null) type)))
+ types
+ :from-end t)))
+ (if last-required
+ (make-values-type :required (subseq types 0 (1+ last-required))
+ :optional (subseq types (1+ last-required))
+ :rest *universal-type*)
+ (make-values-type :optional types :rest *universal-type*))))
+
+(defun make-single-value-type (type)
+ (make-values-type :required (list type)))
;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
;;; type, including VALUES types. With VALUES types such as:
;;; OPERATION returned true as its second value each time we called
;;; it. Since we approximate the intersection of VALUES types, the
;;; second value being true doesn't mean the result is exact.
-(defun args-type-op (type1 type2 operation nreq default-type)
- (declare (type ctype type1 type2 default-type)
+(defun args-type-op (type1 type2 operation nreq)
+ (declare (type ctype type1 type2)
(type function operation nreq))
(when (eq type1 type2)
(values type1 t))
- (if (or (values-type-p type1) (values-type-p type2))
- (let ((type1 (coerce-to-values type1))
- (type2 (coerce-to-values type2)))
- (multiple-value-bind (types1 rest1)
- (values-type-types type1 default-type)
- (multiple-value-bind (types2 rest2)
- (values-type-types type2 default-type)
- (multiple-value-bind (rest rest-exact)
- (funcall operation rest1 rest2)
- (multiple-value-bind (res res-exact)
- (if (< (length types1) (length types2))
- (fixed-values-op types2 types1 rest1 operation)
- (fixed-values-op types1 types2 rest2 operation))
- (let* ((req (funcall nreq
- (length (args-type-required type1))
- (length (args-type-required type2))))
- (required (subseq res 0 req))
- (opt (subseq res req))
- (opt-last (position rest opt :test-not #'type=
- :from-end t)))
- (if (find *empty-type* required :test #'type=)
- (values *empty-type* t)
- (values (make-values-type
- :required required
- :optional (if opt-last
- (subseq opt 0 (1+ opt-last))
- ())
- :rest (if (eq rest default-type) nil rest))
- (and rest-exact res-exact)))))))))
- (funcall operation type1 type2)))
+ (multiple-value-bind (types1 rest1)
+ (values-type-types type1)
+ (multiple-value-bind (types2 rest2)
+ (values-type-types type2)
+ (multiple-value-bind (rest rest-exact)
+ (funcall operation rest1 rest2)
+ (multiple-value-bind (res res-exact)
+ (if (< (length types1) (length types2))
+ (fixed-values-op types2 types1 rest1 operation)
+ (fixed-values-op types1 types2 rest2 operation))
+ (let* ((req (funcall nreq
+ (length (args-type-required type1))
+ (length (args-type-required type2))))
+ (required (subseq res 0 req))
+ (opt (subseq res req)))
+ (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,
:hash-bits 8
:default nil
:init-wrapper !cold-init-forms)
- ((type1 eq) (type2 eq))
+ ((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
(cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)
- ((eq type1 *empty-type*) type2)
- ((eq type2 *empty-type*) type1)
- (t
- (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
+ ((eq type1 *empty-type*) type2)
+ ((eq type2 *empty-type*) type1)
+ (t
+ (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))
+ ((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
- (cond ((eq type1 *wild-type*) (values type2 t))
- ((eq type2 *wild-type*) (values type1 t))
- (t
- (args-type-op type1 type2
- #'type-intersection
- #'max
- (specifier-type 'null)))))
+ (cond ((eq type1 *wild-type*)
+ (coerce-to-values type2))
+ ((or (eq type2 *wild-type*) (eq type2 *universal-type*))
+ 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))))
+ (t
+ (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
(defun values-types-equal-or-intersect (type1 type2)
(cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
(values t t))
- ((or (values-type-p type1) (values-type-p type2))
- (multiple-value-bind (res win) (values-type-intersection type1 type2)
- (values (not (eq res *empty-type*))
- win)))
+ ((or (eq type1 *wild-type*) (eq type2 *wild-type*))
+ (values t t))
(t
- (types-equal-or-intersect type1 type2))))
+ (let ((res (values-type-intersection type1 type2)))
+ (values (not (eq res *empty-type*))
+ t)))))
;;; a SUBTYPEP-like operation that can be used on any types, including
;;; VALUES types
:values 2
:default (values nil :empty)
:init-wrapper !cold-init-forms)
- ((type1 eq) (type2 eq))
+ ((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
- (cond ((eq type2 *wild-type*) (values t t))
- ((eq type1 *wild-type*)
- (values (eq type2 *universal-type*) t))
- ((not (values-types-equal-or-intersect type1 type2))
- (values nil t))
- (t
- (if (or (values-type-p type1) (values-type-p type2))
- (let ((type1 (coerce-to-values type1))
- (type2 (coerce-to-values type2)))
- (multiple-value-bind (types1 rest1) (values-type-types type1)
- (multiple-value-bind (types2 rest2) (values-type-types type2)
- (cond ((< (length (values-type-required type1))
- (length (values-type-required type2)))
- (values nil t))
- ((< (length types1) (length types2))
- (values nil nil))
- ((or (values-type-keyp type1)
- (values-type-keyp type2))
- (values nil nil))
- (t
- (do ((t1 types1 (rest t1))
- (t2 types2 (rest t2)))
- ((null t2)
- (csubtypep rest1 rest2))
- (multiple-value-bind (res win-p)
- (csubtypep (first t1) (first t2))
- (unless win-p
- (return (values nil nil)))
- (unless res
- (return (values nil t))))))))))
- (csubtypep type1 type2)))))
+ (cond ((or (eq type2 *wild-type*) (eq type2 *universal-type*)
+ (eq type1 *empty-type*))
+ (values t t))
+ ((eq type1 *wild-type*)
+ (values (eq type2 *wild-type*) t))
+ ((or (eq type2 *empty-type*)
+ (not (values-types-equal-or-intersect type1 type2)))
+ (values nil t))
+ ((and (not (values-type-p type2))
+ (values-type-required type1))
+ (csubtypep (first (values-type-required type1))
+ type2))
+ (t (setq type2 (coerce-to-values type2))
+ (multiple-value-bind (types1 rest1) (values-type-types type1)
+ (multiple-value-bind (types2 rest2) (values-type-types type2)
+ (cond ((< (length (values-type-required type1))
+ (length (values-type-required type2)))
+ (values nil t))
+ ((< (length types1) (length types2))
+ (values nil nil))
+ (t
+ (do ((t1 types1 (rest t1))
+ (t2 types2 (rest t2)))
+ ((null t2)
+ (csubtypep rest1 rest2))
+ (multiple-value-bind (res win-p)
+ (csubtypep (first t1) (first t2))
+ (unless win-p
+ (return (values nil nil)))
+ (unless res
+ (return (values nil t))))))))))))
\f
;;;; type method interfaces
(declare (type ctype type1 type2))
(cond ((or (eq type1 type2)
(eq type1 *empty-type*)
- (eq type2 *wild-type*))
+ (eq type2 *universal-type*))
(values t t))
- ((eq type1 *wild-type*)
+ #+nil
+ ((eq type1 *universal-type*)
(values nil t))
(t
(!invoke-type-method :simple-subtypep :complex-subtypep-arg2
(declare (type ctype type))
(funcall (type-class-unparse (type-class-info type)) type))
+(defun-cached (type-negation :hash-function (lambda (type)
+ (logand (type-hash-value type)
+ #xff))
+ :hash-bits 8
+ :values 1
+ :default nil
+ :init-wrapper !cold-init-forms)
+ ((type eq))
+ (declare (type ctype type))
+ (funcall (type-class-negate (type-class-info type)) type))
+
;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
;;; early-type.lisp by WHN ca. 19990201.)
;;;; These are fully general operations on CTYPEs: they'll always
;;;; return a CTYPE representing the result.
-;;; shared logic for unions and intersections: Stuff TYPE into the
-;;; vector TYPES, finding pairs of types which can be simplified by
-;;; SIMPLIFY2 (TYPE-UNION2 or TYPE-INTERSECTION2) and replacing them
-;;; by their simplified forms.
-(defun accumulate1-compound-type (type types %compound-type-p simplify2)
- (declare (type ctype type))
- (declare (type (vector ctype) types))
- (declare (type function %compound-type-p simplify2))
- ;; 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
- types
- %compound-type-p
- simplify2)))))
- ;; Voila.
- (values))
-
-;;; shared logic for unions and intersections: Use
-;;; ACCUMULATE1-COMPOUND-TYPE to merge TYPE into TYPES, either
-;;; all in one step or, if %COMPOUND-TYPE-P is satisfied,
-;;; component by component.
-(defun accumulate-compound-type (type types %compound-type-p simplify2)
- (declare (type function %compound-type-p simplify2))
- (flet ((accumulate1 (x)
- (accumulate1-compound-type x types %compound-type-p simplify2)))
- (declare (inline accumulate1))
- (if (funcall %compound-type-p type)
- (map nil #'accumulate1 (compound-type-types type))
- (accumulate1 type)))
- (values))
-
-;;; shared logic for unions and intersections: Return a vector of
-;;; types representing the same types as INPUT-TYPES, but with
+;;; 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.
-(defun simplified-compound-types (input-types %compound-type-p simplify2)
- (let ((simplified-types (make-array (length input-types)
- :fill-pointer 0
- :adjustable t
- :element-type 'ctype
- ;; (This INITIAL-ELEMENT shouldn't
- ;; matter, but helps avoid type
- ;; warnings at compile time.)
- :initial-element *empty-type*)))
- (dolist (input-type input-types)
- (accumulate-compound-type input-type
- simplified-types
- %compound-type-p
- simplify2))
- simplified-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
(!define-type-class named)
-(defvar *wild-type*)
-(defvar *empty-type*)
-(defvar *universal-type*)
-(defvar *universal-fun-type*)
(!cold-init-forms
(macrolet ((frob (name var)
`(progn
- (setq ,var (make-named-type :name ',name))
+ (setq ,var (make-named-type :name ',name))
(setf (info :type :kind ',name)
#+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin ',name) ,var))))
;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
;; special symbol which can be stuck in some places where an
;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
- ;; At some point, in order to become more standard, we should
- ;; convert all the classic CMU CL legacy *s and *WILD-TYPE*s into
- ;; Ts and *UNIVERSAL-TYPE*s.
+ ;; In SBCL it also used to denote universal VALUES type.
(frob * *wild-type*)
(frob nil *empty-type*)
(frob t *universal-type*))
:returns *wild-type*)))
(!define-type-method (named :simple-=) (type1 type2)
- ;; FIXME: BUG 85: This assertion failed when I added it in
- ;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's
- ;; just commented out.
;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
(values nil nil))
(t
;; By elimination, TYPE1 is the universal type.
- (aver (or (eq type1 *wild-type*) (eq type1 *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*)))
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(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))))
+
(!define-type-method (named :unparse) (x)
(named-type-name x))
\f
;;;; hairy and unknown types
+(!define-type-method (hairy :negate) (x)
+ (make-negation-type :type x))
+
(!define-type-method (hairy :unparse) (x)
(hairy-type-specifier x))
-
+
(!define-type-method (hairy :simple-subtypep) (type1 type2)
(let ((hairy-spec1 (hairy-type-specifier type1))
(hairy-spec2 (hairy-type-specifier type2)))
(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)
\f
;;;; negation types
+(!define-type-method (negation :negate) (x)
+ (negation-type-type x))
+
(!define-type-method (negation :unparse) (x)
- `(not ,(type-specifier (negation-type-type x))))
+ (if (type= (negation-type-type x) (specifier-type 'cons))
+ 'atom
+ `(not ,(type-specifier (negation-type-type x)))))
(!define-type-method (negation :simple-subtypep) (type1 type2)
(csubtypep (negation-type-type type2) (negation-type-type type1)))
(let ((complement-type1 (negation-type-type type1)))
;; Do the special cases first, in order to give us a chance if
;; subtype/supertype relationships are hairy.
- (multiple-value-bind (equal certain)
+ (multiple-value-bind (equal certain)
(type= complement-type1 type2)
;; If a = b, ~a is not a subtype of b (unless b=T, which was
;; excluded above).
(type= (negation-type-type type1) (negation-type-type type2)))
(!def-type-translator not (typespec)
- (let* ((not-type (specifier-type typespec))
- (spec (type-specifier not-type)))
- (cond
- ;; canonicalize (NOT (NOT FOO))
- ((and (listp spec) (eq (car spec) 'not))
- (specifier-type (cadr spec)))
- ;; canonicalize (NOT NIL) and (NOT T)
- ((eq not-type *empty-type*) *universal-type*)
- ((eq not-type *universal-type*) *empty-type*)
- ((and (numeric-type-p not-type)
- (null (numeric-type-low not-type))
- (null (numeric-type-high not-type)))
- (make-negation-type :type not-type))
- ((numeric-type-p not-type)
- (type-union
- (make-negation-type
- :type (modified-numeric-type not-type :low nil :high nil))
- (cond
- ((null (numeric-type-low not-type))
- (modified-numeric-type
- not-type
- :low (let ((h (numeric-type-high not-type)))
- (if (consp h) (car h) (list h)))
- :high nil))
- ((null (numeric-type-high not-type))
- (modified-numeric-type
- not-type
- :low nil
- :high (let ((l (numeric-type-low not-type)))
- (if (consp l) (car l) (list l)))))
- (t (type-union
- (modified-numeric-type
- not-type
- :low nil
- :high (let ((l (numeric-type-low not-type)))
- (if (consp l) (car l) (list l))))
- (modified-numeric-type
- not-type
- :low (let ((h (numeric-type-high not-type)))
- (if (consp h) (car h) (list h)))
- :high nil))))))
- ((intersection-type-p not-type)
- (apply #'type-union
- (mapcar #'(lambda (x)
- (specifier-type `(not ,(type-specifier x))))
- (intersection-type-types not-type))))
- ((union-type-p not-type)
- (apply #'type-intersection
- (mapcar #'(lambda (x)
- (specifier-type `(not ,(type-specifier x))))
- (union-type-types not-type))))
- ((member-type-p not-type)
- (let ((members (member-type-members not-type)))
- (if (some #'floatp members)
- (let (floats)
- (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0)
- #!+long-float (0.0l0 . -0.0l0)))
- (when (member (car pair) members)
- (aver (not (member (cdr pair) members)))
- (push (cdr pair) floats)
- (setf members (remove (car pair) members)))
- (when (member (cdr pair) members)
- (aver (not (member (car pair) members)))
- (push (car pair) floats)
- (setf members (remove (cdr pair) members))))
- (apply #'type-intersection
- (if (null members)
- *universal-type*
- (make-negation-type
- :type (make-member-type :members members)))
- (mapcar
- (lambda (x)
- (let ((type (ctype-of x)))
- (type-union
- (make-negation-type
- :type (modified-numeric-type type
- :low nil :high nil))
- (modified-numeric-type type
- :low nil :high (list x))
- (make-member-type :members (list x))
- (modified-numeric-type type
- :low (list x) :high nil))))
- floats)))
- (make-negation-type :type not-type))))
- ((and (cons-type-p not-type)
- (eq (cons-type-car-type not-type) *universal-type*)
- (eq (cons-type-cdr-type not-type) *universal-type*))
- (make-negation-type :type not-type))
- ((cons-type-p not-type)
- (type-union
- (make-negation-type :type (specifier-type 'cons))
- (cond
- ((and (not (eq (cons-type-car-type not-type) *universal-type*))
- (not (eq (cons-type-cdr-type not-type) *universal-type*)))
- (type-union
- (make-cons-type
- (specifier-type `(not ,(type-specifier
- (cons-type-car-type not-type))))
- *universal-type*)
- (make-cons-type
- *universal-type*
- (specifier-type `(not ,(type-specifier
- (cons-type-cdr-type not-type)))))))
- ((not (eq (cons-type-car-type not-type) *universal-type*))
- (make-cons-type
- (specifier-type `(not ,(type-specifier
- (cons-type-car-type not-type))))
- *universal-type*))
- ((not (eq (cons-type-cdr-type not-type) *universal-type*))
- (make-cons-type
- *universal-type*
- (specifier-type `(not ,(type-specifier
- (cons-type-cdr-type not-type))))))
- (t (bug "Weird CONS type ~S" not-type)))))
- (t (make-negation-type :type not-type)))))
+ (type-negation (specifier-type typespec)))
\f
;;;; numeric types
(!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))
+(!define-type-method (number :negate) (type)
+ (if (and (null (numeric-type-low type)) (null (numeric-type-high type)))
+ (make-negation-type :type type)
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type type :low nil :high nil))
+ (cond
+ ((null (numeric-type-low type))
+ (modified-numeric-type
+ type
+ :low (let ((h (numeric-type-high type)))
+ (if (consp h) (car h) (list h)))
+ :high nil))
+ ((null (numeric-type-high type))
+ (modified-numeric-type
+ type
+ :low nil
+ :high (let ((l (numeric-type-low type)))
+ (if (consp l) (car l) (list l)))))
+ (t (type-union
+ (modified-numeric-type
+ type
+ :low nil
+ :high (let ((l (numeric-type-low type)))
+ (if (consp l) (car l) (list l))))
+ (modified-numeric-type
+ type
+ :low (let ((h (numeric-type-high type)))
+ (if (consp h) (car h) (list h)))
+ :high nil)))))))
+
(!define-type-method (number :unparse) (type)
(let* ((complexp (numeric-type-complexp type))
(low (numeric-type-low type))
(:real
base+bounds)
(:complex
- (if (eq base+bounds 'real)
- 'complex
- `(complex ,base+bounds)))
+ (aver (neq base+bounds 'real))
+ `(complex ,base+bounds))
((nil)
(aver (eq base+bounds 'real))
'number)))))
((consp low-bound)
(let ((low-value (car low-bound)))
(or (eql low-value high-bound)
- (and (eql low-value -0f0) (eql high-bound 0f0))
- (and (eql low-value 0f0) (eql high-bound -0f0))
- (and (eql low-value -0d0) (eql high-bound 0d0))
- (and (eql low-value 0d0) (eql high-bound -0d0)))))
+ (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 -0f0) (eql low-bound 0f0))
- (and (eql high-value 0f0) (eql low-bound -0f0))
- (and (eql high-value -0d0) (eql low-bound 0d0))
- (and (eql high-value 0d0) (eql low-bound -0d0)))))
+ (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))
(numeric-type-high type2)
>= > t)))
(t nil))))))
-
+
(!cold-init-forms
(setf (info :type :kind 'number)
(!def-type-translator complex (&optional (typespec '*))
(if (eq typespec '*)
- (make-numeric-type :complexp :complex)
+ (specifier-type '(complex real))
(labels ((not-numeric ()
(error "The component type for COMPLEX is not numeric: ~S"
typespec))
(not-real ()
- (error "The component type for COMPLEX is not real: ~S"
+ (error "The component type for COMPLEX is not a subtype of REAL: ~S"
typespec))
(complex1 (component-type)
(unless (numeric-type-p component-type)
(not-numeric))
(when (eq (numeric-type-complexp component-type) :complex)
(not-real))
- (modified-numeric-type component-type :complexp :complex))
- (complex-union (component)
- (unless (numberp component)
- (not-numeric))
- ;; KLUDGE: This TYPECASE more or less does
- ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)),
- ;; (plus a small hack to treat (EQL COMPONENT 0) specially)
- ;; but uses logic cut and pasted from the DEFUN of
- ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because
- ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE
- ;; would tend to break the code here. Unfortunately,
- ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here
- ;; would cause another kind of fragility, because
- ;; ANSI's definition of TYPE-OF is so weak that e.g.
- ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could
- ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL)
- ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL).
- ;; So using TYPE-OF would mean that ANSI-conforming
- ;; maintenance changes in TYPE-OF could break the code here.
- ;; It's not clear how best to fix this. -- WHN 2002-01-21,
- ;; trying to summarize CSR's concerns in his patch
- (typecase component
- (complex (error "The component type for COMPLEX (EQL X) ~
- is complex: ~S"
- component))
- ((eql 0) (specifier-type nil)) ; as required by ANSI
- (single-float (specifier-type '(complex single-float)))
- (double-float (specifier-type '(complex double-float)))
- #!+long-float
- (long-float (specifier-type '(complex long-float)))
- (rational (specifier-type '(complex rational)))
- (t (specifier-type '(complex real))))))
+ (if (csubtypep component-type (specifier-type '(eql 0)))
+ *empty-type*
+ (modified-numeric-type component-type
+ :complexp :complex))))
(let ((ctype (specifier-type typespec)))
- (typecase ctype
- (numeric-type (complex1 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))))
- ;; MEMBER-TYPE is almost the same as UNION-TYPE, but
- ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to
- ;; ANSI, equal to type NIL, the empty set.
- (member-type (apply #'type-union
- (mapcar #'complex-union
- (member-type-members 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
+ ;; 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))))
(t
(multiple-value-bind (subtypep certainly)
(csubtypep ctype (specifier-type 'real))
(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,
+ ;; 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)))
(specialized-element-type-maybe type2)))
t)))
+(!define-type-method (array :negate) (type)
+ ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
+ ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY
+ ;; NIL) (ARRAY CHAR) ...) equivalent?" -- CSR, 2003-12-10
+ (make-negation-type :type type))
+
(!define-type-method (array :unparse) (type)
(let ((dims (array-type-dimensions type))
(eltype (type-specifier (array-type-element-type type)))
(case eltype
(bit 'bit-vector)
(base-char 'base-string)
- (character 'string)
(* 'vector)
(t `(vector ,eltype)))
(case eltype
(bit `(bit-vector ,(car dims)))
(base-char `(base-string ,(car dims)))
- (character `(string ,(car dims)))
(t `(vector ,eltype ,(car dims)))))
(if (eq (car dims) '*)
(case eltype
(bit 'simple-bit-vector)
(base-char 'simple-base-string)
- (character 'simple-string)
((t) 'simple-vector)
(t `(simple-array ,eltype (*))))
(case eltype
(bit `(simple-bit-vector ,(car dims)))
(base-char `(simple-base-string ,(car dims)))
- (character `(simple-string ,(car dims)))
((t) `(simple-vector ,(car dims)))
(t `(simple-array ,eltype ,dims))))))
(t
(specialized-element-type-maybe type2))
t)))))
+;;; FIXME: is this dead?
(!define-superclasses array
- ((string string)
+ ((base-string base-string)
(vector vector)
(array))
!cold-init-forms)
(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,
(!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*
+ (make-negation-type
+ :type (make-member-type :members members)))
+ (mapcar
+ (lambda (x)
+ (let ((type (ctype-of x)))
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type type
+ :low nil :high nil))
+ (modified-numeric-type type
+ :low nil :high (list x))
+ (make-member-type :members (list x))
+ (modified-numeric-type type
+ :low (list x) :high nil))))
+ floats)))
+ (make-negation-type :type type))))
+
(!define-type-method (member :unparse) (type)
(let ((members (member-type-members type)))
(cond
(float (if (zerop m)
(push m ms)
(push (ctype-of m) numbers)))
- (number (push (ctype-of m) numbers))
+ (real (push (ctype-of m) numbers))
(t (push m ms))))
(apply #'type-union
(if ms
(!define-type-class intersection)
+(!define-type-method (intersection :negate) (type)
+ (apply #'type-union
+ (mapcar #'type-negation (intersection-type-types type))))
+
;;; A few intersection types have special names. The others just get
;;; mechanically unparsed.
(!define-type-method (intersection :unparse) (type)
(return nil)))
(setf accumulator
(type-intersection accumulator union))))))))
-
+
(!def-type-translator and (&whole whole &rest type-specifiers)
(apply #'type-intersection
- (mapcar #'specifier-type
- type-specifiers)))
+ (mapcar #'specifier-type type-specifiers)))
\f
;;;; union types
(!define-type-class union)
+(!define-type-method (union :negate) (type)
+ (declare (type ctype type))
+ (apply #'type-intersection
+ (mapcar #'type-negation (union-type-types type))))
+
;;; The LIST, FLOAT and REAL types have special names. Other union
;;; types just get mechanically unparsed.
(!define-type-method (union :unparse) (type)
((type= type (specifier-type 'real)) 'real)
((type= type (specifier-type 'sequence)) 'sequence)
((type= type (specifier-type 'bignum)) 'bignum)
+ ((type= type (specifier-type 'simple-string)) 'simple-string)
+ ((type= type (specifier-type 'string)) 'string)
+ ((type= type (specifier-type 'complex)) 'complex)
(t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
;;; Two union types are equal if they are each subtypes of each
(!define-type-class cons)
(!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
- (let ((car-type (specifier-type car-type-spec))
- (cdr-type (specifier-type cdr-type-spec)))
+ (let ((car-type (single-value-specifier-type car-type-spec))
+ (cdr-type (single-value-specifier-type cdr-type-spec)))
(make-cons-type car-type cdr-type)))
-
+
+(!define-type-method (cons :negate) (type)
+ (if (and (eq (cons-type-car-type type) *universal-type*)
+ (eq (cons-type-cdr-type type) *universal-type*))
+ (make-negation-type :type type)
+ (type-union
+ (make-negation-type :type (specifier-type 'cons))
+ (cond
+ ((and (not (eq (cons-type-car-type type) *universal-type*))
+ (not (eq (cons-type-cdr-type type) *universal-type*)))
+ (type-union
+ (make-cons-type
+ (type-negation (cons-type-car-type type))
+ *universal-type*)
+ (make-cons-type
+ *universal-type*
+ (type-negation (cons-type-cdr-type type)))))
+ ((not (eq (cons-type-car-type type) *universal-type*))
+ (make-cons-type
+ (type-negation (cons-type-car-type type))
+ *universal-type*))
+ ((not (eq (cons-type-cdr-type type) *universal-type*))
+ (make-cons-type
+ *universal-type*
+ (type-negation (cons-type-cdr-type type))))
+ (t (bug "Weird CONS type ~S" type))))))
+
(!define-type-method (cons :unparse) (type)
(let ((car-eltype (type-specifier (cons-type-car-type type)))
(cdr-eltype (type-specifier (cons-type-cdr-type type))))
(let ((car-type1 (cons-type-car-type type1))
(car-type2 (cons-type-car-type type2))
(cdr-type1 (cons-type-cdr-type type1))
- (cdr-type2 (cons-type-cdr-type type2)))
+ (cdr-type2 (cons-type-cdr-type type2))
+ car-not1
+ car-not2)
;; UGH. -- CSR, 2003-02-24
- (macrolet ((frob-car (car1 car2 cdr1 cdr2)
+ (macrolet ((frob-car (car1 car2 cdr1 cdr2
+ &optional (not1 nil not1p))
`(type-union
(make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
(make-cons-type
(type-intersection ,car2
- (specifier-type
- `(not ,(type-specifier ,car1))))
+ ,(if not1p
+ not1
+ `(type-negation ,car1)))
,cdr2))))
(cond ((type= car-type1 car-type2)
(make-cons-type car-type1
(frob-car car-type1 car-type2 cdr-type1 cdr-type2))
((csubtypep car-type2 car-type1)
(frob-car car-type2 car-type1 cdr-type2 cdr-type1))
+ ;; more general case of the above, but harder to compute
+ ((progn
+ (setf car-not1 (type-negation car-type1))
+ (not (csubtypep car-type2 car-not1)))
+ (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)))
+ (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
;; (CONS (INTEGER 0 3) (INTEGER 5 6)).
(!define-type-method (cons :simple-intersection2) (type1 type2)
(declare (type cons-type type1 type2))
- (let (car-int2
- cdr-int2)
- (and (setf car-int2 (type-intersection2 (cons-type-car-type type1)
- (cons-type-car-type type2)))
- (setf cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
- (cons-type-cdr-type type2)))
- (make-cons-type car-int2 cdr-int2))))
-\f
+ (let ((car-int2 (type-intersection2 (cons-type-car-type type1)
+ (cons-type-car-type type2)))
+ (cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2))))
+ (cond
+ ((and car-int2 cdr-int2) (make-cons-type car-int2 cdr-int2))
+ (car-int2 (make-cons-type car-int2
+ (type-intersection
+ (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2))))
+ (cdr-int2 (make-cons-type
+ (type-intersection (cons-type-car-type type1)
+ (cons-type-car-type type2))
+ cdr-int2)))))
+\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.
;;;
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
:complexp :maybe
- :element-type (specifier-type element-type))))
+ :element-type (if (eq element-type '*)
+ *wild-type*
+ (specifier-type element-type)))))
(!def-type-translator simple-array (&optional (element-type '*)
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
:complexp nil
- :element-type (specifier-type element-type))))
+ :element-type (if (eq element-type '*)
+ *wild-type*
+ (specifier-type element-type)))))
\f
;;;; utilities shared between cross-compiler and target system
projects / sbcl.git / blobdiff