X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=861ff4550fe183f18e557503d9956f80e3b4245e;hb=a64589ed34ce0298fae164476af7de14c4652909;hp=15b8cb518a8faa4318a55d9a0ece0d54e2347646;hpb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 15b8cb5..861ff45 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -22,14 +22,13 @@ ;;; ### Remaining incorrectnesses: ;;; -;;; TYPE-UNION (and the OR type) doesn't properly canonicalize an -;;; exhaustive partition or coalesce contiguous ranges of numeric -;;; types. -;;; ;;; There are all sorts of nasty problems with open bounds on FLOAT ;;; types (and probably FLOAT types in general.) -;;; -;;; RATIO and BIGNUM are not recognized as numeric types. + +;;; 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.) @@ -103,8 +102,7 @@ ;;; ;;; 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) @@ -157,7 +155,13 @@ (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2))) (!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 @@ -180,10 +184,7 @@ (!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)) + (cond ((and rest1 rest2 (type/= rest1 rest2)) (type= rest1 rest2)) ((or rest1 rest2) (values nil t)) @@ -231,43 +232,41 @@ (csubtypep a1 a2) (unless res (return (values res sure-p)))) finally (return (values t t))))) - (macrolet ((3and (x y) - `(multiple-value-bind (val1 win1) ,x - (if (and (not val1) win1) - (values nil t) - (multiple-value-bind (val2 win2) ,y - (if (and val1 val2) - (values t t) - (values nil (and win2 (not val2))))))))) - (3and (values-subtypep (fun-type-returns type1) - (fun-type-returns type2)) - (cond ((fun-type-wild-args type2) (values t t)) - ((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 (3and (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)) - (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) - (multiple-value-bind (min2 max2) (fun-type-nargs type2) - (cond ((or (> max1 max2) (< min1 min2)) - (values nil t)) - ((and (= min1 min2) (= max1 max2)) - (3and (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) - (fun-type-optional type1)) - (concatenate 'list - (fun-type-required type2) - (fun-type-optional type2))))))))))))) + (and/type (values-subtypep (fun-type-returns type1) + (fun-type-returns type2)) + (cond ((fun-type-wild-args type2) (values t t)) + ((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 (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) + (multiple-value-bind (min2 max2) (fun-type-nargs type2) + (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)))) + (t (every-csubtypep + (concatenate 'list + (fun-type-required type1) + (fun-type-optional type1)) + (concatenate 'list + (fun-type-required type2) + (fun-type-optional type2)))))))))))) (!define-superclasses function ((function)) !cold-init-forms) @@ -276,13 +275,84 @@ (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. +(!define-type-method (function :complex-intersection2) (type1 type2) + (cond + ((type= type1 (specifier-type 'function)) type2) + ((csubtypep type1 (specifier-type 'function)) nil) + (t :call-other-method))) +(!define-type-method (function :complex-union2) (type1 type2) + (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 (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)))))))))) (!define-type-class constant :inherits values) @@ -293,38 +363,7 @@ (type= (constant-type-type type1) (constant-type-type type2))) (!def-type-translator constant-arg (type) - (make-constant-type :type (specifier-type type))) - -;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE -;;; structure, fill in the slots in the structure accordingly. This is -;;; used for both FUNCTION and VALUES types. -(declaim (ftype (function (list args-type) (values)) parse-args-types)) -(defun parse-args-types (lambda-list result) - (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) - (parse-lambda-list-like-thing lambda-list) - (declare (ignore aux)) ; since we require AUXP=NIL - (when auxp - (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) - (setf (args-type-required result) - (mapcar #'single-value-specifier-type required)) - (setf (args-type-optional result) - (mapcar #'single-value-specifier-type optional)) - (setf (args-type-rest result) - (if restp (single-value-specifier-type rest) nil)) - (setf (args-type-keyp result) keyp) - (collect ((key-info)) - (dolist (key keys) - (unless (proper-list-of-length-p key 2) - (error "Keyword type description is not a two-list: ~S." key)) - (let ((kwd (first key))) - (when (find kwd (key-info) :key #'key-info-name) - (error "~@" - kwd lambda-list)) - (key-info (make-key-info :name kwd - :type (single-value-specifier-type (second key)))))) - (setf (args-type-keywords result) (key-info))) - (setf (args-type-allowp result) allowp) - (values))) + (make-constant-type :type (single-value-specifier-type type))) ;;; Return the lambda-list-like type specification corresponding ;;; to an ARGS-TYPE. @@ -356,46 +395,46 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (let ((res (make-fun-type :returns (values-specifier-type result)))) - (if (eq args '*) - (setf (fun-type-wild-args res) t) - (parse-args-types args res)) - res)) + (make-fun-type :args args + :returns (coerce-to-values (values-specifier-type result)))) (!def-type-translator values (&rest values) - (let ((res (%make-values-type))) - (parse-args-types values res) - res)) + (make-values-type :args values)) ;;;; VALUES types interfaces ;;;; ;;;; 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 ;;; type, return NIL, NIL. (defun fun-type-nargs (type) (declare (type ctype type)) - (if (fun-type-p type) + (if (and (fun-type-p type) (not (fun-type-wild-args type))) (let ((fixed (length (args-type-required type)))) (if (or (args-type-rest type) (args-type-keyp type) @@ -410,31 +449,45 @@ ;;; 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))))) + +;;; If COUNT values are supplied, which types should they have? +(defun values-type-start (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)))) ;;; Return a list of OPERATION applied to the types in TYPES1 and ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter @@ -455,13 +508,47 @@ :initial-element rest2))) exact))) -;;; If TYPE isn't a values type, then make it into one: -;;; ==> (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: @@ -486,41 +573,36 @@ ;;; 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))) ;;; Do a union or intersection operation on types that might be values ;;; types. The result is optimized for utility rather than exactness, @@ -533,27 +615,38 @@ :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) :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*) (values (coerce-to-values type2) t)) + ((or (eq type2 *wild-type*) (eq type2 *universal-type*)) + (values type1 t)) + ((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-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 @@ -562,12 +655,12 @@ (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)) + ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) + (values t t)) + (t (multiple-value-bind (res win) (values-type-intersection type1 type2) (values (not (eq res *empty-type*)) - win))) - (t - (types-equal-or-intersect type1 type2)))) + win))))) ;;; a SUBTYPEP-like operation that can be used on any types, including ;;; VALUES types @@ -576,39 +669,39 @@ :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)))))))))))) ;;;; type method interfaces @@ -622,9 +715,10 @@ (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 @@ -730,14 +824,14 @@ (flet ((1way (x y) (!invoke-type-method :simple-intersection2 :complex-intersection2 x y - :default :no-type-method-found))) + :default :call-other-method))) (declare (inline 1way)) (let ((xy (1way type1 type2))) - (or (and (not (eql xy :no-type-method-found)) xy) + (or (and (not (eql xy :call-other-method)) xy) (let ((yx (1way type2 type1))) - (or (and (not (eql yx :no-type-method-found)) yx) - (cond ((and (eql xy :no-type-method-found) - (eql yx :no-type-method-found)) + (or (and (not (eql yx :call-other-method)) yx) + (cond ((and (eql xy :call-other-method) + (eql yx :call-other-method)) *empty-type*) (t (aver (and (not xy) (not yx))) ; else handled above @@ -831,71 +925,45 @@ ;;;; 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 +;;; 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) - (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)) + (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-compound-type-or-something (constructor types enumerable identity) +(defun make-probably-compound-type (constructor types enumerable identity) (declare (type function constructor)) (declare (type (vector ctype) types)) (declare (type ctype identity)) @@ -909,7 +977,7 @@ ;; 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-COMPOUND-TYPE-OR-SOMETHING + ;; 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. @@ -957,11 +1025,11 @@ :specifier `(and ,@(map 'list #'type-specifier simplified-types))))) - (make-compound-type-or-something #'%make-intersection-type - simplified-types - (some #'type-enumerable - simplified-types) - *universal-type*)))) + (make-probably-compound-type #'%make-intersection-type + simplified-types + (some #'type-enumerable + simplified-types) + *universal-type*)))) (defun type-union (&rest input-types) (%type-union input-types)) @@ -972,10 +1040,10 @@ (let ((simplified-types (simplified-compound-types input-types #'union-type-p #'type-union2))) - (make-compound-type-or-something #'make-union-type - simplified-types - (every #'type-enumerable simplified-types) - *empty-type*))) + (make-probably-compound-type #'make-union-type + simplified-types + (every #'type-enumerable simplified-types) + *empty-type*))) ;;;; built-in types @@ -985,19 +1053,18 @@ (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*)) @@ -1006,9 +1073,6 @@ :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)) @@ -1059,7 +1123,7 @@ (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*))) @@ -1100,7 +1164,7 @@ (!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))) @@ -1117,8 +1181,12 @@ (values nil nil)) (!define-type-method (hairy :complex-=) (type1 type2) - (declare (ignore type1 type2)) - (values nil nil)) + (if (unknown-type-p type2) + (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) @@ -1192,7 +1260,7 @@ (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). @@ -1357,6 +1425,41 @@ (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 . ,(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 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*)) @@ -1398,8 +1501,8 @@ (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)) - (equal (numeric-type-low type1) (numeric-type-low type2)) - (equal (numeric-type-high type1) (numeric-type-high type2))) + (equalp (numeric-type-low type1) (numeric-type-low type2)) + (equalp (numeric-type-high type1) (numeric-type-high type2))) t)) (!define-type-method (number :unparse) (type) @@ -1459,7 +1562,6 @@ ;;; ;;; This is for comparing bounds of the same kind, e.g. upper and ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds. -#!-negative-zero-is-not-zero (defmacro numeric-bound-test (x y closed open) `(cond ((not ,y) t) ((not ,x) nil) @@ -1472,32 +1574,12 @@ (,open ,x (car ,y)) (,closed ,x ,y))))) -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test-zero (op x y) - `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y)) - (,op (float-sign ,x) (float-sign ,y)) - (,op ,x ,y))) - -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test (x y closed open) - `(cond ((not ,y) t) - ((not ,x) nil) - ((consp ,x) - (if (consp ,y) - (numeric-bound-test-zero ,closed (car ,x) (car ,y)) - (numeric-bound-test-zero ,closed (car ,x) ,y))) - (t - (if (consp ,y) - (numeric-bound-test-zero ,open ,x (car ,y)) - (numeric-bound-test-zero ,closed ,x ,y))))) - ;;; This is used to compare upper and lower bounds. This is different ;;; from the same-bound case: ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we ;;; return true if *either* arg is NIL. ;;; -- an open inner bound is "greater" and also squeezes the interval, ;;; causing us to use the OPEN test for those cases as well. -#!-negative-zero-is-not-zero (defmacro numeric-bound-test* (x y closed open) `(cond ((not ,y) t) ((not ,x) t) @@ -1510,19 +1592,6 @@ (,open ,x (car ,y)) (,closed ,x ,y))))) -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test* (x y closed open) - `(cond ((not ,y) t) - ((not ,x) t) - ((consp ,x) - (if (consp ,y) - (numeric-bound-test-zero ,open (car ,x) (car ,y)) - (numeric-bound-test-zero ,open (car ,x) ,y))) - (t - (if (consp ,y) - (numeric-bound-test-zero ,open ,x (car ,y)) - (numeric-bound-test-zero ,closed ,x ,y))))) - ;;; Return whichever of the numeric bounds X and Y is "maximal" ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >). ;;; This is only meaningful for maximizing like bounds, i.e. upper and @@ -1586,28 +1655,43 @@ (cond ((not (and low-bound high-bound)) nil) ((and (consp low-bound) (consp high-bound)) nil) ((consp low-bound) - #!-negative-zero-is-not-zero (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)))) - #!+negative-zero-is-not-zero - (eql (car low-bound) 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))))))) ((consp high-bound) - #!-negative-zero-is-not-zero (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)))) - #!+negative-zero-is-not-zero - (eql (car high-bound) low-bound)) - #!+negative-zero-is-not-zero - ((or (and (eql low-bound -0f0) (eql high-bound 0f0)) - (and (eql low-bound -0d0) (eql high-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)) @@ -1689,7 +1773,7 @@ (numeric-type-high type2) >= > t))) (t nil)))))) - + (!cold-init-forms (setf (info :type :kind 'number) @@ -2252,7 +2336,10 @@ (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, @@ -2364,6 +2451,9 @@ (let (ms numbers) (dolist (m (remove-duplicates members)) (typecase m + (float (if (zerop m) + (push m ms) + (push (ctype-of m) numbers))) (number (push (ctype-of m) numbers)) (t (push m ms)))) (apply #'type-union @@ -2404,15 +2494,13 @@ ;;; shared machinery for type equality: true if every type in the set ;;; TYPES1 matches a type in the set TYPES2 and vice versa (defun type=-set (types1 types2) - (flet (;; true if every type in the set X matches a type in the set Y - (type<=-set (x y) + (flet ((type<=-set (x y) (declare (type list x y)) - (every (lambda (xelement) - (position xelement y :test #'type=)) - x))) - (values (and (type<=-set types1 types2) - (type<=-set types2 types1)) - t))) + (every/type (lambda (x y-element) + (any/type #'type= y-element x)) + x y))) + (and/type (type<=-set types1 types2) + (type<=-set types2 types1)))) ;;; Two intersection types are equal if their subtypes are equal sets. ;;; @@ -2513,7 +2601,7 @@ (return nil))) (setf accumulator (type-intersection accumulator union)))))))) - + (!def-type-translator and (&whole whole &rest type-specifiers) (apply #'type-intersection (mapcar #'specifier-type @@ -2686,8 +2774,8 @@ (!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 :unparse) (type) @@ -2813,14 +2901,18 @@ (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))))) ;;;; utilities shared between cross-compiler and target system