X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=930ea76bb560839c1fccbb80419a5d313cfe0a98;hb=4ed3f0d08c3a57a6762018d9622f253ab9d0f2b6;hp=861ff4550fe183f18e557503d9956f80e3b4245e;hpb=a64589ed34ce0298fae164476af7de14c4652909;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 861ff45..930ea76 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -182,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) @@ -327,32 +314,7 @@ (values nil t)) ((eq (fun-type-wild-args type1) t) (values t t)) - (t (and/type - (cond ((null (fun-type-rest type1)) - (values (null (fun-type-rest type2)) t)) - ((null (fun-type-rest type2)) - (values nil t)) - (t - (compare type= rest))) - (labels ((type-list-= (l1 l2) - (cond ((null l1) - (values (null l2) t)) - ((null l2) - (values nil t)) - (t (multiple-value-bind (res winp) - (type= (first l1) (first l2)) - (cond ((not winp) - (values nil nil)) - ((not res) - (values nil t)) - (t - (type-list-= (rest l1) - (rest l2))))))))) - (and/type (and/type (compare type-list-= required) - (compare type-list-= optional)) - (if (or (fun-type-keyp type1) (fun-type-keyp type2)) - (values nil nil) - (values t t)))))))))) + (t (type=-args type1 type2)))))) (!define-type-class constant :inherits values) @@ -470,8 +432,8 @@ (cond ((args-type-rest type)) (t default-type))))) -;;; If COUNT values are supplied, which types should they have? -(defun values-type-start (type count) +;;; types of values in (the (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*) @@ -489,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 @@ -604,6 +589,23 @@ :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) @@ -625,28 +627,28 @@ (defun-cached (values-type-intersection :hash-function type-cache-hash :hash-bits 8 - :values 2 - :default (values nil :empty) + :default (values nil) :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) - (cond ((eq type1 *wild-type*) (values (coerce-to-values type2) t)) + (cond ((eq type1 *wild-type*) + (coerce-to-values type2)) ((or (eq type2 *wild-type*) (eq type2 *universal-type*)) - (values type1 t)) + type1) ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) *empty-type*) ((and (not (values-type-p type2)) (values-type-required type1)) (let ((req1 (values-type-required type1))) - (make-values-type :required (cons (type-intersection (first req1) type2) - (rest req1)) - :optional (values-type-optional type1) - :rest (values-type-rest type1) - :allowp (values-type-allowp type1)))) + (make-values-type :required (cons (type-intersection (first req1) type2) + (rest req1)) + :optional (values-type-optional type1) + :rest (values-type-rest type1) + :allowp (values-type-allowp type1)))) (t - (values-type-op type1 (coerce-to-values type2) - #'type-intersection - #'max)))) + (values (values-type-op type1 (coerce-to-values type2) + #'type-intersection + #'max))))) ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of ;;; works on VALUES types. Note that due to the semantics of @@ -658,9 +660,9 @@ ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) (values t t)) (t - (multiple-value-bind (res win) (values-type-intersection type1 type2) + (let ((res (values-type-intersection type1 type2))) (values (not (eq res *empty-type*)) - win))))) + t))))) ;;; a SUBTYPEP-like operation that can be used on any types, including ;;; VALUES types @@ -925,65 +927,27 @@ ;;;; These are fully general operations on CTYPEs: they'll always ;;;; return a CTYPE representing the result. -;;; shared logic for unions and intersections: Return a vector of +;;; shared logic for unions and intersections: Return a list of ;;; types representing the same types as INPUT-TYPES, but with ;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their ;;; component types, and with any SIMPLY2 simplifications applied. -(declaim (inline simplified-compound-types)) -(defun simplified-compound-types (input-types %compound-type-p simplify2) - (declare (function %compound-type-p simplify2)) - (let ((types (make-array (length input-types) - :fill-pointer 0 - :adjustable t - :element-type 'ctype))) - (labels ((accumulate-compound-type (type) - (if (funcall %compound-type-p type) - (dolist (type (compound-type-types type)) - (accumulate1-compound-type type)) - (accumulate1-compound-type type))) - (accumulate1-compound-type (type) - (declare (type ctype type)) - ;; Any input object satisfying %COMPOUND-TYPE-P should've been - ;; broken into components before it reached us. - (aver (not (funcall %compound-type-p type))) - (dotimes (i (length types) (vector-push-extend type types)) - (let ((simplified2 (funcall simplify2 type (aref types i)))) - (when simplified2 - ;; Discard the old (AREF TYPES I). - (setf (aref types i) (vector-pop types)) - ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing. - ;; (Note that the tail recursion is indirect: we go through - ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is - ;; handled properly if it satisfies %COMPOUND-TYPE-P.) - (return (accumulate-compound-type simplified2))))))) - (dolist (input-type input-types) - (accumulate-compound-type input-type))) - types)) - -;;; shared logic for unions and intersections: Make a COMPOUND-TYPE -;;; object whose components are the types in TYPES, or skip to special -;;; cases when TYPES is short. -(defun make-probably-compound-type (constructor types enumerable identity) - (declare (type function constructor)) - (declare (type (vector ctype) types)) - (declare (type ctype identity)) - (case (length types) - (0 identity) - (1 (aref types 0)) - (t (funcall constructor - enumerable - ;; FIXME: This should be just (COERCE TYPES 'LIST), but as - ;; of sbcl-0.6.11.17 the COERCE optimizer is really - ;; brain-dead, so that would generate a full call to - ;; SPECIFIER-TYPE at runtime, so we get into bootstrap - ;; problems in cold init because 'LIST is a compound - ;; type, so we need to MAKE-PROBABLY-COMPOUND-TYPE - ;; before we know what 'LIST is. Once the COERCE - ;; optimizer is less brain-dead, we can make this - ;; (COERCE TYPES 'LIST) again. - #+sb-xc-host (coerce types 'list) - #-sb-xc-host (coerce-to-list types))))) - +(macrolet + ((def (name compound-type-p simplify2) + `(defun ,name (types) + (when types + (multiple-value-bind (first rest) + (if (,compound-type-p (car types)) + (values (car (compound-type-types (car types))) + (append (cdr (compound-type-types (car types))) + (cdr types))) + (values (car types) (cdr types))) + (let ((rest (,name rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (,simplify2 first r)) + (return (,name (nsubstitute u r rest))))))))))) + (def simplify-intersections intersection-type-p type-intersection2) + (def simplify-unions union-type-p type-union2)) + (defun maybe-distribute-one-union (union-type types) (let* ((intersection (apply #'type-intersection types)) (union (mapcar (lambda (x) (type-intersection x intersection)) @@ -1000,10 +964,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 @@ -1012,8 +974,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)) @@ -1025,11 +986,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)) @@ -1037,13 +999,13 @@ :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 @@ -1181,7 +1143,12 @@ (values nil nil)) (!define-type-method (hairy :complex-=) (type1 type2) - (if (unknown-type-p type2) + (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) @@ -1496,11 +1463,15 @@ (!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)) @@ -2200,25 +2171,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 @@ -2266,8 +2233,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) @@ -2621,6 +2589,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 @@ -2840,14 +2810,21 @@ (!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))))) + ;;; 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. ;;;