X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=147656e7a4e4efdf4e1f271faf8fc91acf0b743a;hb=568214ddf4c8ecc881caec98e20848d017974ec0;hp=c74a081d29c33e1e0ff0a812844e4f8f1685512c;hpb=670010e3f3dcd62efaf23f61abdc73950edb88c6;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index c74a081..147656e 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -25,6 +25,11 @@ ;;; 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 @@ -149,8 +154,17 @@ (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 @@ -171,23 +185,7 @@ (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) @@ -197,6 +195,9 @@ (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 @@ -230,10 +231,14 @@ ((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)) @@ -242,10 +247,12 @@ (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) @@ -261,8 +268,36 @@ (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. @@ -272,17 +307,30 @@ ((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)))) @@ -290,7 +338,7 @@ (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. @@ -322,7 +370,8 @@ (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)) @@ -332,23 +381,28 @@ ;;;; 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 @@ -370,31 +424,68 @@ ;;; 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 (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 ... +(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 @@ -415,13 +506,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: @@ -446,41 +571,53 @@ ;;; 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, @@ -493,27 +630,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) + :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 @@ -522,12 +670,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)) - (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 @@ -536,39 +684,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 @@ -582,9 +730,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 @@ -762,6 +911,17 @@ (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.) @@ -791,91 +951,27 @@ ;;;; 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)) @@ -892,10 +988,8 @@ :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 @@ -904,8 +998,7 @@ ;; 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)) @@ -917,11 +1010,12 @@ :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)) @@ -929,35 +1023,29 @@ :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))))) ;;;; 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*)) @@ -966,9 +1054,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)) @@ -1019,7 +1104,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*))) @@ -1053,14 +1138,24 @@ ;;(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)) ;;;; 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))) @@ -1077,8 +1172,17 @@ (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) @@ -1114,8 +1218,13 @@ ;;;; 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))) @@ -1152,7 +1261,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). @@ -1266,135 +1375,56 @@ (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))) ;;;; 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)) @@ -1435,9 +1465,8 @@ (: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))))) @@ -1547,17 +1576,41 @@ ((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)) @@ -1639,7 +1692,7 @@ (numeric-type-high type2) >= > t))) (t nil)))))) - + (!cold-init-forms (setf (info :type :kind 'number) @@ -1649,68 +1702,55 @@ (!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)))) + ((and (typep ctype 'intersection-type) + ;; FIXME: This is very much a + ;; not-quite-worst-effort, but we are required to do + ;; something here because of our representation of + ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must + ;; allow users to ask about (COMPLEX RATIO). This + ;; will of course fail to work right on such types + ;; as (AND INTEGER (SATISFIES ZEROP))... + (let ((numbers (remove-if-not + #'numeric-type-p + (intersection-type-types ctype)))) + (and (car numbers) + (null (cdr numbers)) + (eq (numeric-type-complexp (car numbers)) :real) + (complex1 (car numbers)))))) (t (multiple-value-bind (subtypep certainly) (csubtypep ctype (specifier-type 'real)) @@ -1718,11 +1758,12 @@ (not-real) ;; ANSI just says that TYPESPEC is any subtype of ;; type REAL, not necessarily a NUMERIC-TYPE. In - ;; particular, at this point TYPESPEC could legally be - ;; an intersection type like (AND REAL (SATISFIES ODDP)), - ;; in which case we fall through the logic above and - ;; end up here, stumped. - (bug "~@<(known bug #145): The type ~S is too hairy to be + ;; particular, at this point TYPESPEC could legally + ;; be a hairy type like (AND NUMBER (SATISFIES + ;; REALP) (SATISFIES ZEROP)), in which case we fall + ;; through the logic above and end up here, + ;; stumped. + (bug "~@<(known bug #145): The type ~S is too hairy to be ~ used for a COMPLEX component.~:@>" typespec))))))))) @@ -1795,38 +1836,92 @@ ;;; FIXME: It's probably necessary to do something to fix the ;;; analogous problem with INTEGER and RATIONAL types. Perhaps ;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER). -(defun coerce-bound (bound type inner-coerce-bound-fun) +(defun coerce-bound (bound type upperp inner-coerce-bound-fun) (declare (type function inner-coerce-bound-fun)) - (cond ((eql bound '*) - bound) - ((consp bound) - (destructuring-bind (inner-bound) bound - (list (funcall inner-coerce-bound-fun inner-bound type)))) - (t - (funcall inner-coerce-bound-fun bound type)))) -(defun inner-coerce-real-bound (bound type) - (ecase type - (rational (rationalize bound)) - (float (if (floatp bound) - bound - ;; Coerce to the widest float format available, to - ;; avoid unnecessary loss of precision: - (coerce bound 'long-float))))) -(defun coerced-real-bound (bound type) - (coerce-bound bound type #'inner-coerce-real-bound)) -(defun coerced-float-bound (bound type) - (coerce-bound bound type #'coerce)) + (if (eql bound '*) + bound + (funcall inner-coerce-bound-fun bound type upperp))) +(defun inner-coerce-real-bound (bound type upperp) + #+sb-xc-host (declare (ignore upperp)) + (let #+sb-xc-host () + #-sb-xc-host + ((nl (load-time-value (symbol-value 'sb!xc:most-negative-long-float))) + (pl (load-time-value (symbol-value 'sb!xc:most-positive-long-float)))) + (let ((nbound (if (consp bound) (car bound) bound)) + (consp (consp bound))) + (ecase type + (rational + (if consp + (list (rational nbound)) + (rational nbound))) + (float + (cond + ((floatp nbound) bound) + (t + ;; Coerce to the widest float format available, to avoid + ;; unnecessary loss of precision, but don't coerce + ;; unrepresentable numbers, except on the host where we + ;; shouldn't be making these types (but KLUDGE: can't even + ;; assert portably that we're not). + #-sb-xc-host + (ecase upperp + ((nil) + (when (< nbound nl) (return-from inner-coerce-real-bound nl))) + ((t) + (when (> nbound pl) (return-from inner-coerce-real-bound pl)))) + (let ((result (coerce nbound 'long-float))) + (if consp (list result) result))))))))) +(defun inner-coerce-float-bound (bound type upperp) + #+sb-xc-host (declare (ignore upperp)) + (let #+sb-xc-host () + #-sb-xc-host + ((nd (load-time-value (symbol-value 'sb!xc:most-negative-double-float))) + (pd (load-time-value (symbol-value 'sb!xc:most-positive-double-float))) + (ns (load-time-value (symbol-value 'sb!xc:most-negative-single-float))) + (ps (load-time-value + (symbol-value 'sb!xc:most-positive-single-float)))) + (let ((nbound (if (consp bound) (car bound) bound)) + (consp (consp bound))) + (ecase type + (single-float + (cond + ((typep nbound 'single-float) bound) + (t + #-sb-xc-host + (ecase upperp + ((nil) + (when (< nbound ns) (return-from inner-coerce-float-bound ns))) + ((t) + (when (> nbound ps) (return-from inner-coerce-float-bound ps)))) + (let ((result (coerce nbound 'single-float))) + (if consp (list result) result))))) + (double-float + (cond + ((typep nbound 'double-float) bound) + (t + #-sb-xc-host + (ecase upperp + ((nil) + (when (< nbound nd) (return-from inner-coerce-float-bound nd))) + ((t) + (when (> nbound pd) (return-from inner-coerce-float-bound pd)))) + (let ((result (coerce nbound 'double-float))) + (if consp (list result) result))))))))) +(defun coerced-real-bound (bound type upperp) + (coerce-bound bound type upperp #'inner-coerce-real-bound)) +(defun coerced-float-bound (bound type upperp) + (coerce-bound bound type upperp #'inner-coerce-float-bound)) (!def-type-translator real (&optional (low '*) (high '*)) - (specifier-type `(or (float ,(coerced-real-bound low 'float) - ,(coerced-real-bound high 'float)) - (rational ,(coerced-real-bound low 'rational) - ,(coerced-real-bound high 'rational))))) + (specifier-type `(or (float ,(coerced-real-bound low 'float nil) + ,(coerced-real-bound high 'float t)) + (rational ,(coerced-real-bound low 'rational nil) + ,(coerced-real-bound high 'rational t))))) (!def-type-translator float (&optional (low '*) (high '*)) (specifier-type - `(or (single-float ,(coerced-float-bound low 'single-float) - ,(coerced-float-bound high 'single-float)) - (double-float ,(coerced-float-bound low 'double-float) - ,(coerced-float-bound high 'double-float)) + `(or (single-float ,(coerced-float-bound low 'single-float nil) + ,(coerced-float-bound high 'single-float t)) + (double-float ,(coerced-float-bound low 'double-float nil) + ,(coerced-float-bound high 'double-float t)) #!+long-float ,(error "stub: no long float support yet")))) (defmacro !define-float-format (f) @@ -2039,7 +2134,7 @@ (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))) @@ -2052,6 +2147,12 @@ (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))) @@ -2065,26 +2166,24 @@ (if (eq (car dims) '*) (case eltype (bit 'bit-vector) - (base-char 'base-string) - (character 'string) + ((base-char #!-sb-unicode character) 'base-string) (* 'vector) (t `(vector ,eltype))) (case eltype (bit `(bit-vector ,(car dims))) - (base-char `(base-string ,(car dims))) - (character `(string ,(car dims))) + ((base-char #!-sb-unicode character) + `(base-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) + ((base-char #!-sb-unicode character) 'simple-base-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))) + ((base-char #!-sb-unicode character) + `(simple-base-string ,(car dims))) ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) (t @@ -2132,8 +2231,9 @@ (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) @@ -2202,7 +2302,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, @@ -2233,6 +2336,42 @@ (!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 @@ -2311,18 +2450,24 @@ (!def-type-translator member (&rest members) (if members - (let (ms numbers) + (let (ms numbers char-codes) (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)) + (real (push (ctype-of m) numbers)) + (character (push (sb!xc:char-code m) char-codes)) (t (push m ms)))) (apply #'type-union (if ms (make-member-type :members ms) *empty-type*) + (if char-codes + (make-character-set-type + :pairs (mapcar (lambda (x) (cons x x)) + (sort char-codes #'<))) + *empty-type*) (nreverse numbers))) *empty-type*)) @@ -2347,6 +2492,10 @@ (!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) @@ -2464,16 +2613,20 @@ (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))) ;;;; 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) @@ -2484,6 +2637,10 @@ ((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) + ((type= type (specifier-type 'standard-char)) 'standard-char) (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each @@ -2637,10 +2794,36 @@ (!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)))) @@ -2671,15 +2854,19 @@ (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 @@ -2691,6 +2878,15 @@ (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)). @@ -2703,13 +2899,103 @@ (!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)))) + (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))))) + +;;;; CHARACTER-SET types + +(!define-type-class character-set) + +(!def-type-translator character-set + (&optional (pairs '((0 . #.(1- sb!xc:char-code-limit))))) + (make-character-set-type :pairs pairs)) + +(!define-type-method (character-set :negate) (type) + (let ((pairs (character-set-type-pairs type))) + (if (and (= (length pairs) 1) + (= (caar pairs) 0) + (= (cdar pairs) (1- sb!xc:char-code-limit))) + (make-negation-type :type type) + (let ((not-character + (make-negation-type + :type (make-character-set-type + :pairs '((0 . #.(1- sb!xc:char-code-limit))))))) + (type-union + not-character + (make-character-set-type + :pairs (let (not-pairs) + (when (> (caar pairs) 0) + (push (cons 0 (1- (caar pairs))) not-pairs)) + (do* ((tail pairs (cdr tail)) + (high1 (cdar tail)) + (low2 (caadr tail))) + ((null (cdr tail)) + (when (< (cdar tail) (1- sb!xc:char-code-limit)) + (push (cons (1+ (cdar tail)) + (1- sb!xc:char-code-limit)) + not-pairs)) + (nreverse not-pairs)) + (push (cons (1+ high1) (1- low2)) not-pairs))))))))) + +(!define-type-method (character-set :unparse) (type) + (cond + ((type= type (specifier-type 'character)) 'character) + ((type= type (specifier-type 'base-char)) 'base-char) + ((type= type (specifier-type 'extended-char)) 'extended-char) + ((type= type (specifier-type 'standard-char)) 'standard-char) + (t (let ((pairs (character-set-type-pairs type))) + `(member ,@(loop for (low . high) in pairs + append (loop for code from low upto high + collect (sb!xc:code-char code)))))))) + +(!define-type-method (character-set :simple-=) (type1 type2) + (let ((pairs1 (character-set-type-pairs type1)) + (pairs2 (character-set-type-pairs type2))) + (values (equal pairs1 pairs2) t))) + +(!define-type-method (character-set :simple-subtypep) (type1 type2) + (values + (dolist (pair (character-set-type-pairs type1) t) + (unless (position pair (character-set-type-pairs type2) + :test (lambda (x y) (and (>= (car x) (car y)) + (<= (cdr x) (cdr y))))) + (return nil))) + t)) + +(!define-type-method (character-set :simple-union2) (type1 type2) + ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function + ;; actually does the union for us. It might be a little fragile to + ;; rely on it. + (make-character-set-type + :pairs (merge 'list + (copy-alist (character-set-type-pairs type1)) + (copy-alist (character-set-type-pairs type2)) + #'< :key #'car))) + +(!define-type-method (character-set :simple-intersection2) (type1 type2) + ;; KLUDGE: brute force. + (let (pairs) + (dolist (pair1 (character-set-type-pairs type1) + (make-character-set-type + :pairs (sort pairs #'< :key #'car))) + (dolist (pair2 (character-set-type-pairs type2)) + (cond + ((<= (car pair1) (car pair2) (cdr pair1)) + (push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs)) + ((<= (car pair2) (car pair1) (cdr pair2)) + (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs))))))) ;;; 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. @@ -2764,14 +3050,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 @@ -2820,7 +3110,11 @@ (values :complex (min num imag) (max num imag))) (values :real num num)) (make-numeric-type :class (etypecase num - (integer 'integer) + (integer (if (complexp x) + (if (integerp (imagpart x)) + 'integer + 'rational) + 'integer)) (rational 'rational) (float 'float)) :format (and (floatp num) (float-format-name num))