X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=e0b7317f0fb28850daa788b1fd3fec9b4c5a7c3d;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=f7c60500516822cad5cdddab011137dab581ea64;hpb=05525d3a5906d7a89fcb689c26177732493c40ce;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index f7c6050..e0b7317 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 @@ -150,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 @@ -171,20 +182,7 @@ (return (values nil t)))))) (!define-type-method (values :simple-=) (type1 type2) - (let ((rest1 (args-type-rest type1)) - (rest2 (args-type-rest type2))) - (cond ((and rest1 rest2 (type/= rest1 rest2)) - (type= rest1 rest2)) - ((or rest1 rest2) - (values nil t)) - (t - (multiple-value-bind (req-val req-win) - (type=-list (values-type-required type1) - (values-type-required type2)) - (multiple-value-bind (opt-val opt-win) - (type=-list (values-type-optional type1) - (values-type-optional type2)) - (values (and req-val opt-val) (and req-win opt-win)))))))) + (type=-args type1 type2)) (!define-type-class function) @@ -227,10 +225,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)) @@ -239,10 +241,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) @@ -258,8 +262,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. @@ -273,10 +305,16 @@ ((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) @@ -287,7 +325,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. @@ -394,9 +432,9 @@ (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 (ctype type) (unsigned-byte count)) +;;; 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)) @@ -413,6 +451,29 @@ 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 ;;; than TYPES2. The second value is T if OPERATION always returned a @@ -517,12 +578,34 @@ (length (args-type-required type2)))) (required (subseq res 0 req)) (opt (subseq res req))) - (values (make-values-type - :required required - :optional opt - :rest rest) + (values required opt rest (and rest-exact res-exact)))))))) +(defun values-type-op (type1 type2 operation nreq) + (multiple-value-bind (required optional rest exactp) + (args-type-op type1 type2 operation nreq) + (values (make-values-type :required required + :optional optional + :rest rest) + exactp))) + +(defun type=-args (type1 type2) + (macrolet ((compare (comparator field) + (let ((reader (symbolicate '#:args-type- field))) + `(,comparator (,reader type1) (,reader type2))))) + (and/type + (cond ((null (args-type-rest type1)) + (values (null (args-type-rest type2)) t)) + ((null (args-type-rest type2)) + (values nil t)) + (t + (compare type= rest))) + (and/type (and/type (compare type=-list required) + (compare type=-list optional)) + (if (or (args-type-keyp type1) (args-type-keyp type2)) + (values nil nil) + (values t t)))))) + ;;; Do a union or intersection operation on types that might be values ;;; types. The result is optimized for utility rather than exactness, ;;; but it is guaranteed that it will be no smaller (more restrictive) @@ -540,7 +623,7 @@ ((eq type1 *empty-type*) type2) ((eq type2 *empty-type*) type1) (t - (values (args-type-op type1 type2 #'type-union #'min))))) + (values (values-type-op type1 type2 #'type-union #'min))))) (defun-cached (values-type-intersection :hash-function type-cache-hash :hash-bits 8 @@ -563,9 +646,9 @@ :rest (values-type-rest type1) :allowp (values-type-allowp type1)))) (t - (args-type-op type1 (coerce-to-values type2) - #'type-intersection - #'max)))) + (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 @@ -972,10 +1055,11 @@ (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)))) @@ -1099,8 +1183,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) @@ -1571,17 +1664,41 @@ ((consp low-bound) (let ((low-value (car low-bound))) (or (eql low-value high-bound) - (and (eql low-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0)) - (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero)))) - (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0)) - (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero))))))) + (and (eql low-value + (load-time-value (make-unportable-float + :single-float-negative-zero))) + (eql high-bound 0f0)) + (and (eql low-value 0f0) + (eql high-bound + (load-time-value (make-unportable-float + :single-float-negative-zero)))) + (and (eql low-value + (load-time-value (make-unportable-float + :double-float-negative-zero))) + (eql high-bound 0d0)) + (and (eql low-value 0d0) + (eql high-bound + (load-time-value (make-unportable-float + :double-float-negative-zero))))))) ((consp high-bound) (let ((high-value (car high-bound))) (or (eql high-value low-bound) - (and (eql high-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0)) - (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero)))) - (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0)) - (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero))))))) + (and (eql high-value + (load-time-value (make-unportable-float + :single-float-negative-zero))) + (eql low-bound 0f0)) + (and (eql high-value 0f0) + (eql low-bound + (load-time-value (make-unportable-float + :single-float-negative-zero)))) + (and (eql high-value + (load-time-value (make-unportable-float + :double-float-negative-zero))) + (eql low-bound 0d0)) + (and (eql high-value 0d0) + (eql low-bound + (load-time-value (make-unportable-float + :double-float-negative-zero))))))) ((and (eq (numeric-type-class low) 'integer) (eq (numeric-type-class high) 'integer)) (eql (1+ low-bound) high-bound)) @@ -2090,25 +2207,21 @@ (case eltype (bit 'bit-vector) (base-char 'base-string) - (character 'string) (* 'vector) (t `(vector ,eltype))) (case eltype (bit `(bit-vector ,(car dims))) (base-char `(base-string ,(car dims))) - (character `(string ,(car dims))) (t `(vector ,eltype ,(car dims))))) (if (eq (car dims) '*) (case eltype (bit 'simple-bit-vector) (base-char 'simple-base-string) - (character 'simple-string) ((t) 'simple-vector) (t `(simple-array ,eltype (*)))) (case eltype (bit `(simple-bit-vector ,(car dims))) (base-char `(simple-base-string ,(car dims))) - (character `(simple-string ,(car dims))) ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) (t @@ -2156,8 +2269,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) @@ -2226,7 +2340,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, @@ -2508,6 +2625,8 @@ ((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) (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each @@ -2661,8 +2780,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) @@ -2788,14 +2907,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