X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=5d3b8452b9b8e9103c74d6307545e1a4fbf98763;hb=8d404ad80075771ffb783fda8a7328982a67f820;hp=4b9296549cc513e7f878453e6e7267289ce0e27f;hpb=722703e7cbd3a4b279a4c1baab5d95df2c23cce9;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 4b92965..5d3b845 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -69,7 +69,7 @@ ;; If TYPE2 might be concealing something related to our class ;; hierarchy (if (type-might-contain-other-types-p type2) - ;; too confusing, gotta punt + ;; too confusing, gotta punt (values nil nil) ;; ordinary case expected by old CMU CL code, where the taxonomy ;; of TYPE2's representation accurately reflects the taxonomy of @@ -213,11 +213,60 @@ (type-specifier (fun-type-returns type))))) -;;; Since all function types are equivalent to FUNCTION, they are all -;;; subtypes of each other. +;;; The meaning of this is a little confused. On the one hand, all +;;; function objects are represented the same way regardless of the +;;; arglists and return values, and apps don't get to ask things like +;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the +;;; other hand, Python wants to reason about function types. So... (!define-type-method (function :simple-subtypep) (type1 type2) - (declare (ignore type1 type2)) - (values t t)) + (flet ((fun-type-simple-p (type) + (not (or (fun-type-rest type) + (fun-type-keyp type)))) + (every-csubtypep (types1 types2) + (loop + for a1 in types1 + for a2 in types2 + do (multiple-value-bind (res sure-p) + (csubtypep a1 a2) + (unless res (return (values res sure-p)))) + finally (return (values t t))))) + (macrolet ((3and (x y) + `(multiple-value-bind (val1 win1) ,x + (if (and (not val1) win1) + (values nil t) + (multiple-value-bind (val2 win2) ,y + (if (and val1 val2) + (values t t) + (values nil (and win2 (not val2))))))))) + (3and (values-subtypep (fun-type-returns type1) + (fun-type-returns type2)) + (cond ((fun-type-wild-args type2) (values t t)) + ((fun-type-wild-args type1) + (cond ((fun-type-keyp type2) (values nil nil)) + ((not (fun-type-rest type2)) (values nil t)) + ((not (null (fun-type-required type2))) (values nil t)) + (t (3and (type= *universal-type* (fun-type-rest type2)) + (every/type #'type= *universal-type* + (fun-type-optional type2)))))) + ((not (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) + (multiple-value-bind (min2 max2) (fun-type-nargs type2) + (cond ((or (> max1 max2) (< min1 min2)) + (values nil t)) + ((and (= min1 min2) (= max1 max2)) + (3and (every-csubtypep (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep (fun-type-optional type1) + (fun-type-optional type2)))) + (t (every-csubtypep + (concatenate 'list + (fun-type-required type1) + (fun-type-optional type1)) + (concatenate 'list + (fun-type-required type2) + (fun-type-optional type2))))))))))))) (!define-superclasses function ((function)) !cold-init-forms) @@ -250,13 +299,17 @@ ;;; used for both FUNCTION and VALUES types. (declaim (ftype (function (list args-type) (values)) parse-args-types)) (defun parse-args-types (lambda-list result) - (multiple-value-bind (required optional restp rest keyp keys allowp aux) - (parse-lambda-list lambda-list) - (when aux + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) + (parse-lambda-list-like-thing lambda-list) + (declare (ignore aux)) ; since we require AUXP=NIL + (when auxp (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) - (setf (args-type-required result) (mapcar #'specifier-type required)) - (setf (args-type-optional result) (mapcar #'specifier-type optional)) - (setf (args-type-rest result) (if restp (specifier-type rest) nil)) + (setf (args-type-required result) + (mapcar #'single-value-specifier-type required)) + (setf (args-type-optional result) + (mapcar #'single-value-specifier-type optional)) + (setf (args-type-rest result) + (if restp (single-value-specifier-type rest) nil)) (setf (args-type-keyp result) keyp) (collect ((key-info)) (dolist (key keys) @@ -267,7 +320,7 @@ (error "~@" kwd lambda-list)) (key-info (make-key-info :name kwd - :type (specifier-type (second key)))))) + :type (single-value-specifier-type (second key)))))) (setf (args-type-keywords result) (key-info))) (setf (args-type-allowp result) allowp) (values))) @@ -309,7 +362,7 @@ res)) (!def-type-translator values (&rest values) - (let ((res (make-values-type))) + (let ((res (%make-values-type))) (parse-args-types values res) res)) @@ -401,7 +454,7 @@ :initial-element rest2))) exact))) -;;; If Type isn't a values type, then make it into one: +;;; If TYPE isn't a values type, then make it into one: ;;; ==> (values type &rest t) (defun coerce-to-values (type) (declare (type ctype type)) @@ -435,6 +488,8 @@ (defun args-type-op (type1 type2 operation nreq default-type) (declare (type ctype type1 type2 default-type) (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))) @@ -576,12 +631,13 @@ :complex-arg1 :complex-subtypep-arg1)))) ;;; Just parse the type specifiers and call CSUBTYPE. -(defun sb!xc:subtypep (type1 type2) +(defun sb!xc:subtypep (type1 type2 &optional environment) #!+sb-doc "Return two values indicating the relationship between type1 and type2. If values are T and T, type1 definitely is a subtype of type2. If values are NIL and T, type1 definitely is not a subtype of type2. If values are NIL and NIL, it couldn't be determined." + (declare (ignore environment)) (csubtypep (specifier-type type1) (specifier-type type2))) ;;; If two types are definitely equivalent, return true. The second @@ -756,7 +812,17 @@ (let ((res (specifier-type spec))) (unless (unknown-type-p res) (setf (info :type :builtin spec) res) - (setf (info :type :kind spec) :primitive)))) + ;; KLUDGE: the three copies of this idiom in this file (and + ;; the one in class.lisp as at sbcl-0.7.4.1x) should be + ;; coalesced, or perhaps the error-detecting code that + ;; disallows redefinition of :PRIMITIVE types should be + ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than + ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to + ;; cause redefinition errors when precompute-types is called + ;; for a second time while building the target compiler using + ;; the cross-compiler. -- CSR, trying to explain why this + ;; isn't completely wrong, 2002-06-07 + (setf (info :type :kind spec) #+sb-xc-host :defined #-sb-xc-host :primitive)))) (values)) ;;;; general TYPE-UNION and TYPE-INTERSECTION operations @@ -771,7 +837,7 @@ (defun accumulate1-compound-type (type types %compound-type-p simplify2) (declare (type ctype type)) (declare (type (vector ctype) types)) - (declare (type function simplify2)) + (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))) @@ -849,7 +915,22 @@ #+sb-xc-host (coerce types 'list) #-sb-xc-host (coerce-to-list types))))) +(defun maybe-distribute-one-union (union-type types) + (let* ((intersection (apply #'type-intersection types)) + (union (mapcar (lambda (x) (type-intersection x intersection)) + (union-type-types union-type)))) + (if (notany (lambda (x) (or (hairy-type-p x) + (intersection-type-p x))) + union) + union + nil))) + (defun type-intersection (&rest input-types) + (%type-intersection input-types)) +(defun-cached (%type-intersection :hash-bits 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))) @@ -860,11 +941,21 @@ ;; always achieve that by the distributive rule. But we don't want ;; to just apply the distributive rule, since it would be too easy ;; to end up with unreasonably huge type expressions. So instead - ;; we punt to HAIRY-TYPE when this comes up. + ;; 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)) - (make-hairy-type - :specifier `(and ,@(map 'list #'type-specifier simplified-types))) + (let* ((first-union (find-if #'union-type-p simplified-types)) + (other-types (coerce (remove first-union simplified-types) + 'list)) + (distributed (maybe-distribute-one-union first-union + other-types))) + (if distributed + (apply #'type-union distributed) + (make-hairy-type + :specifier `(and ,@(map 'list + #'type-specifier + simplified-types))))) (make-compound-type-or-something #'%make-intersection-type simplified-types (some #'type-enumerable @@ -872,10 +963,15 @@ *universal-type*)))) (defun type-union (&rest input-types) + (%type-union input-types)) +(defun-cached (%type-union :hash-bits 8 + :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-compound-type-or-something #'%make-union-type + (make-compound-type-or-something #'make-union-type simplified-types (every #'type-enumerable simplified-types) *empty-type*))) @@ -892,7 +988,8 @@ (macrolet ((frob (name var) `(progn (setq ,var (make-named-type :name ',name)) - (setf (info :type :kind ',name) :primitive) + (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 @@ -981,8 +1078,9 @@ ;;;; hairy and unknown types -(!define-type-method (hairy :unparse) (x) (hairy-type-specifier 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))) @@ -1103,12 +1201,23 @@ (declare (ignore type1 type2)) (values nil nil)) -(!define-type-method (hairy :simple-intersection2 :complex-intersection2) +(!define-type-method (hairy :simple-intersection2) (type1 type2) (if (type= type1 type2) type1 nil)) +(!define-type-method (hairy :complex-intersection2) + (type1 type2) + (aver (hairy-type-p type2)) + (let ((hairy-type-spec (type-specifier type2))) + (if (and (consp hairy-type-spec) + (eq (car hairy-type-spec) 'not)) + (if (csubtypep type1 (specifier-type (cadr hairy-type-spec))) + *empty-type* + nil) + nil))) + (!define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) (hairy-type-specifier type2)) @@ -1135,7 +1244,7 @@ (error 'simple-type-error :datum predicate-name :expected-type 'symbol - :format-control "~S is not a symbol." + :format-control "The SATISFIES predicate name is not a symbol: ~S" :format-arguments (list predicate-name)))) ;; Create object. (make-hairy-type :specifier whole)) @@ -1325,7 +1434,7 @@ (t (values nil t))))) -(!define-superclasses number ((generic-number)) !cold-init-forms) +(!define-superclasses number ((number)) !cold-init-forms) ;;; If the high bound of LOW is adjacent to the low bound of HIGH, ;;; then return true, otherwise NIL. @@ -1396,7 +1505,8 @@ >= > t))))))) (!cold-init-forms - (setf (info :type :kind 'number) :primitive) + (setf (info :type :kind 'number) + #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin 'number) (make-numeric-type :complexp nil))) @@ -1505,7 +1615,7 @@ ;; previously we threw an error here: ;; (error "Lower bound ~S is greater than upper bound ~S." l h)) ;; but ANSI doesn't say anything about that, so: - (specifier-type 'nil) + *empty-type* (make-numeric-type :class 'integer :complexp :real :enumerable (not (null (and l h))) @@ -1520,8 +1630,11 @@ ;; as above, previously we did ;; (error "Lower bound ~S is not less than upper bound ~S." low high)) ;; but it is correct to do - (specifier-type 'nil) - (make-numeric-type :class ',class :format ',format :low lb :high hb))))) + *empty-type* + (make-numeric-type :class ',class + :format ',format + :low lb + :high hb))))) (!def-bounded-type rational rational nil) @@ -1790,13 +1903,23 @@ (array-type-element-type type))) (!define-type-method (array :simple-=) (type1 type2) - (values (and (equal (array-type-dimensions type1) - (array-type-dimensions type2)) - (eq (array-type-complexp type1) - (array-type-complexp type2)) - (type= (specialized-element-type-maybe type1) - (specialized-element-type-maybe type2))) - t)) + (if (or (unknown-type-p (array-type-element-type type1)) + (unknown-type-p (array-type-element-type type2))) + (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, + ;; 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))) + (values equalp certainp)) + (values (and (equal (array-type-dimensions type1) + (array-type-dimensions type2)) + (eq (array-type-complexp type1) + (array-type-complexp type2)) + (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2))) + t))) (!define-type-method (array :unparse) (type) (let ((dims (array-type-dimensions type)) @@ -1902,10 +2025,28 @@ (eq complexp2 :maybe) (eq complexp1 complexp2))) (values nil t)) - ;; If either element type is wild, then they intersect. - ;; Otherwise, the types must be identical. - ((or (eq (array-type-element-type type1) *wild-type*) - (eq (array-type-element-type type2) *wild-type*) + ;; Old comment: + ;; + ;; If either element type is wild, then they intersect. + ;; Otherwise, the types must be identical. + ;; + ;; FIXME: There seems to have been a fair amount of + ;; confusion about the distinction between requested element + ;; type and specialized element type; here is one of + ;; them. If we request an array to hold objects of an + ;; unknown type, we can do no better than represent that + ;; type as an array specialized on wild-type. We keep the + ;; requested element-type in the -ELEMENT-TYPE slot, and + ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here, + ;; we must test for the SPECIALIZED slot being *WILD-TYPE*, + ;; not just the ELEMENT-TYPE slot. Maybe the return value + ;; in that specific case should be T, NIL? Or maybe this + ;; function should really be called + ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this + ;; was responsible for bug #123, and this whole issue could + ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21 + ((or (eq (array-type-specialized-element-type type1) *wild-type*) + (eq (array-type-specialized-element-type type2) *wild-type*) (type= (specialized-element-type-maybe type1) (specialized-element-type-maybe type2))) @@ -1963,9 +2104,10 @@ (!define-type-method (member :unparse) (type) (let ((members (member-type-members type))) - (if (equal members '(nil)) - 'null - `(member ,@members)))) + (cond + ((equal members '(nil)) 'null) + ((type= type (specifier-type 'standard-char)) 'standard-char) + (t `(member ,@members))))) (!define-type-method (member :simple-subtypep) (type1 type2) (values (subsetp (member-type-members type1) (member-type-members type2)) @@ -1997,7 +2139,7 @@ *empty-type*)))))) (!define-type-method (member :complex-intersection2) (type1 type2) - (block punt + (block punt (collect ((members)) (let ((mem2 (member-type-members type2))) (dolist (member mem2) @@ -2118,13 +2260,16 @@ (!define-type-class union) -;;; The LIST type has a special name. Other union types just get -;;; mechanically unparsed. +;;; The LIST, FLOAT and REAL types have special names. Other union +;;; types just get mechanically unparsed. (!define-type-method (union :unparse) (type) (declare (type ctype type)) - (if (type= type (specifier-type 'list)) - 'list - `(or ,@(mapcar #'type-specifier (union-type-types type))))) + (cond + ((type= type (specifier-type 'list)) 'list) + ((type= type (specifier-type 'float)) 'float) + ((type= type (specifier-type 'real)) 'real) + ((type= type (specifier-type 'sequence)) 'sequence) + (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each ;;; other. We need to be this clever because our complex subtypep @@ -2150,6 +2295,7 @@ (values nil certain?)))))) (!define-type-method (union :complex-=) (type1 type2) + (declare (ignore type1)) (if (some #'hairy-type-p (union-type-types type2)) (values nil nil) (values nil t))) @@ -2279,8 +2425,12 @@ (!define-type-class cons) (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) - (make-cons-type (specifier-type car-type-spec) - (specifier-type cdr-type-spec))) + (let ((car-type (specifier-type car-type-spec)) + (cdr-type (specifier-type cdr-type-spec))) + (if (or (eq car-type *empty-type*) + (eq cdr-type *empty-type*)) + *empty-type* + (make-cons-type car-type cdr-type)))) (!define-type-method (cons :unparse) (type) (let ((car-eltype (type-specifier (cons-type-car-type type))) @@ -2382,14 +2532,15 @@ (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) + :complexp :maybe :element-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) - :element-type (specifier-type element-type) - :complexp nil))) + :complexp nil + :element-type (specifier-type element-type)))) ;;;; utilities shared between cross-compiler and target system