X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flate-type.lisp;h=5da592904386f4c0ef52455c39c668e5d60daf19;hb=814fc23f60ba84318a3dfea112e6d98fd0293835;hp=98943af37fbaee1af6a2e7cdecb6d121fea9d2b2;hpb=95816dfe1bac897f06fcd8c7b2a4579d76f841d0;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 98943af..5da5929 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -31,9 +31,9 @@ ;;; ;;; RATIO and BIGNUM are not recognized as numeric types. -;;; FIXME: It seems to me that this should be set to NIL by default, -;;; and perhaps not even optionally set to T. -(defvar *use-implementation-types* t +;;; 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 #!+sb-doc "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how restrictive we are in determining type membership. If two types are the @@ -41,7 +41,6 @@ this switch is on. When it is off, we try to be as restrictive as the language allows, allowing us to detect more errors. Currently, this only affects array types.") - (!cold-init-forms (setq *use-implementation-types* t)) ;;; These functions are used as method for types which need a complex @@ -66,21 +65,29 @@ ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 ;;; method. INFO is a list of conses ;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). -;;; This will never be called with a hairy type as TYPE2, since the -;;; hairy type TYPE2 method gets first crack. (defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info) - (values - (and (sb!xc:typep type2 'sb!xc:class) - (dolist (x info nil) - (when (or (not (cdr x)) - (csubtypep type1 (specifier-type (cdr x)))) - (return - (or (eq type2 (car x)) - (let ((inherits (layout-inherits (class-layout (car x))))) - (dotimes (i (length inherits) nil) - (when (eq type2 (layout-class (svref inherits i))) - (return t))))))))) - t)) + ;; If TYPE2 might be concealing something related to our class + ;; hierarchy + (if (type-might-contain-other-types-p type2) + ;; 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 + ;; the underlying set + (values + ;; FIXME: This old CMU CL code probably deserves a comment + ;; explaining to us mere mortals how it works... + (and (sb!xc:typep type2 'sb!xc:class) + (dolist (x info nil) + (when (or (not (cdr x)) + (csubtypep type1 (specifier-type (cdr x)))) + (return + (or (eq type2 (car x)) + (let ((inherits (layout-inherits (class-layout (car x))))) + (dotimes (i (length inherits) nil) + (when (eq type2 (layout-class (svref inherits i))) + (return t))))))))) + t))) ;;; This function takes a list of specs, each of the form ;;; (SUPERCLASS-NAME &OPTIONAL GUARD). @@ -132,10 +139,10 @@ ;;; the description of a &KEY argument (defstruct (key-info #-sb-xc-host (:pure t) (:copier nil)) - ;; the key (not necessarily a keyword in ANSI) - (name (required-argument) :type symbol) + ;; the key (not necessarily a keyword in ANSI Common Lisp) + (name (missing-arg) :type symbol) ;; the type of the argument value - (type (required-argument) :type ctype)) + (type (missing-arg) :type ctype)) (!define-type-method (values :simple-subtypep :complex-subtypep-arg1) (type1 type2) @@ -193,24 +200,73 @@ ;;; a flag that we can bind to cause complex function types to be ;;; unparsed as FUNCTION. This is useful when we want a type that we ;;; can pass to TYPEP. -(defvar *unparse-function-type-simplify*) -(!cold-init-forms (setq *unparse-function-type-simplify* nil)) +(defvar *unparse-fun-type-simplify*) +(!cold-init-forms (setq *unparse-fun-type-simplify* nil)) (!define-type-method (function :unparse) (type) - (if *unparse-function-type-simplify* + (if *unparse-fun-type-simplify* 'function (list 'function - (if (function-type-wild-args type) + (if (fun-type-wild-args type) '* (unparse-args-types type)) (type-specifier - (function-type-returns type))))) + (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) @@ -230,12 +286,12 @@ (!define-type-class constant :inherits values) (!define-type-method (constant :unparse) (type) - `(constant-argument ,(type-specifier (constant-type-type type)))) + `(constant-arg ,(type-specifier (constant-type-type type)))) (!define-type-method (constant :simple-=) (type1 type2) (type= (constant-type-type type1) (constant-type-type type2))) -(!def-type-translator constant-argument (type) +(!def-type-translator constant-arg (type) (make-constant-type :type (specifier-type type))) ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE @@ -243,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) @@ -260,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))) @@ -295,15 +355,14 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (let ((res (make-function-type - :returns (values-specifier-type result)))) + (let ((res (make-fun-type :returns (values-specifier-type result)))) (if (eq args '*) - (setf (function-type-wild-args res) t) + (setf (fun-type-wild-args res) t) (parse-args-types args res)) res)) (!def-type-translator values (&rest values) - (let ((res (make-values-type))) + (let ((res (%make-values-type))) (parse-args-types values res) res)) @@ -333,9 +392,9 @@ ;;; Return the minimum number of arguments that a function can be ;;; called with, and the maximum number or NIL. If not a function ;;; type, return NIL, NIL. -(defun function-type-nargs (type) +(defun fun-type-nargs (type) (declare (type ctype type)) - (if (function-type-p type) + (if (fun-type-p type) (let ((fixed (length (args-type-required type)))) (if (or (args-type-rest type) (args-type-keyp type) @@ -383,19 +442,19 @@ (defun fixed-values-op (types1 types2 rest2 operation) (declare (list types1 types2) (type ctype rest2) (type function operation)) (let ((exact t)) - (values (mapcar #'(lambda (t1 t2) - (multiple-value-bind (res win) - (funcall operation t1 t2) - (unless win - (setq exact nil)) - res)) + (values (mapcar (lambda (t1 t2) + (multiple-value-bind (res win) + (funcall operation t1 t2) + (unless win + (setq exact nil)) + res)) types1 (append types2 (make-list (- (length types1) (length types2)) :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)) @@ -429,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))) @@ -466,7 +527,7 @@ ;;; than the precise result. ;;; ;;; The return convention seems to be analogous to -;;; TYPES-INTERSECT. -- WHN 19990910. +;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910. (defun-cached (values-type-union :hash-function type-cache-hash :hash-bits 8 :default nil @@ -493,22 +554,19 @@ #'max (specifier-type 'null))))) -;;; This is like TYPES-INTERSECT, except that it sort of works on -;;; VALUES types. Note that due to the semantics of +;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of +;;; works on VALUES types. Note that due to the semantics of ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when -;;; there isn't really any intersection (?). -;;; -;;; The return convention seems to be analogous to -;;; TYPES-INTERSECT. -- WHN 19990910. -(defun values-types-intersect (type1 type2) +;;; there isn't really any intersection. +(defun values-types-equal-or-intersect (type1 type2) (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) - (values 't t)) + (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))) (t - (types-intersect type1 type2)))) + (types-equal-or-intersect type1 type2)))) ;;; a SUBTYPEP-like operation that can be used on any types, including ;;; VALUES types @@ -522,7 +580,7 @@ (cond ((eq type2 *wild-type*) (values t t)) ((eq type1 *wild-type*) (values (eq type2 *universal-type*) t)) - ((not (values-types-intersect type1 type2)) + ((not (values-types-equal-or-intersect type1 type2)) (values nil t)) (t (if (or (values-type-p type1) (values-type-p type2)) @@ -565,8 +623,7 @@ (eq type1 *empty-type*) (eq type2 *wild-type*)) (values t t)) - ((or (eq type1 *wild-type*) - (eq type2 *empty-type*)) + ((eq type1 *wild-type*) (values nil t)) (t (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 @@ -574,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 @@ -615,17 +673,9 @@ ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish ;; between not finding a method and having a method return NIL. (flet ((1way (x y) - (let ((result (!invoke-type-method :simple-union2 :complex-union2 - x y - :default nil))) - ;; UNION2 type methods are supposed to return results - ;; which are better than just brute-forcibly smashing the - ;; terms together into UNION-TYPEs. But they're derived - ;; from old CMU CL UNION type methods which played by - ;; somewhat different rules. Here we check to make sure - ;; we don't get ambushed by diehard old-style code. - (assert (not (union-type-p result))) - result))) + (!invoke-type-method :simple-union2 :complex-union2 + x y + :default nil))) (declare (inline 1way)) (or (1way type1 type2) (1way type2 type1)))) @@ -646,6 +696,8 @@ (declare (type ctype type1 type2)) (cond ((eq type1 type2) type1) + ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) ((or (union-type-p type1) (union-type-p type2)) ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES @@ -675,20 +727,9 @@ ;; ;; (Why yes, CLOS probably *would* be nicer..) (flet ((1way (x y) - (let ((result - (!invoke-type-method :simple-intersection2 - :complex-intersection2 - x y - :default :no-type-method-found))) - ;; INTERSECTION2 type methods are supposed to return - ;; results which are better than just brute-forcibly - ;; smashing the terms together into INTERSECTION-TYPEs. - ;; But they're derived from old CMU CL INTERSECTION type - ;; methods which played by somewhat different rules. Here - ;; we check to make sure we don't get ambushed by diehard - ;; old-style code. - (assert (not (intersection-type-p result))) - result))) + (!invoke-type-method :simple-intersection2 :complex-intersection2 + x y + :default :no-type-method-found))) (declare (inline 1way)) (let ((xy (1way type1 type2))) (or (and (not (eql xy :no-type-method-found)) xy) @@ -698,7 +739,7 @@ (eql yx :no-type-method-found)) *empty-type*) (t - (assert (and (not xy) (not yx))) ; else handled above + (aver (and (not xy) (not yx))) ; else handled above nil)))))))) (defun-cached (type-intersection2 :hash-function type-cache-hash @@ -709,6 +750,9 @@ ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) (cond ((eq type1 type2) + ;; FIXME: For some reason, this doesn't catch e.g. type1 = + ;; type2 = (SPECIFIER-TYPE + ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 type1) ((or (intersection-type-p type1) (intersection-type-p type2)) @@ -730,15 +774,15 @@ ((hairy-type-p type1) type2) (t type1))) -;;; The first value is true unless the types don't intersect. The -;;; second value is true if the first value is definitely correct. NIL -;;; is considered to intersect with any type. If T is a subtype of -;;; either type, then we also return T, T. This way we recognize -;;; that hairy types might intersect with T. +;;; a test useful for checking whether a derived type matches a +;;; declared type ;;; -;;; FIXME: It would be more accurate to call this TYPES-MIGHT-INTERSECT, -;;; and rename VALUES-TYPES-INTERSECT the same way. -(defun types-intersect (type1 type2) +;;; The first value is true unless the types don't intersect and +;;; aren't equal. The second value is true if the first value is +;;; definitely correct. NIL is considered to intersect with any type. +;;; If T is a subtype of either type, then we also return T, T. This +;;; way we recognize that hairy types might intersect with T. +(defun types-equal-or-intersect (type1 type2) (declare (type ctype type1 type2)) (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) (values t t) @@ -768,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 @@ -783,10 +837,10 @@ (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. - (assert (not (funcall %compound-type-p type))) + (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 @@ -824,6 +878,7 @@ (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 @@ -860,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))) @@ -871,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 @@ -883,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*))) @@ -898,12 +983,13 @@ (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)) - (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 @@ -913,43 +999,65 @@ ;; Ts and *UNIVERSAL-TYPE*s. (frob * *wild-type*) (frob nil *empty-type*) - (frob t *universal-type*))) + (frob t *universal-type*)) + (setf *universal-fun-type* + (make-fun-type :wild-args t + :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. - ;;(assert (not (eq type1 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (eq type1 type2) t)) (!define-type-method (named :simple-subtypep) (type1 type2) - (assert (not (eq type1 *wild-type*))) ; * isn't really a type. + (aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) (!define-type-method (named :complex-subtypep-arg1) (type1 type2) - (assert (not (eq type1 *wild-type*))) ; * isn't really a type. - ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause - ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over - ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..) - (assert (not (hairy-type-p type2))) - ;; Besides the old CMU CL assertion above, we also need to avoid - ;; compound types, else we could get into trouble with - ;; (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR))) - ;; or - ;; (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))). - (assert (not (compound-type-p type2))) - ;; Then, since TYPE2 is reasonably tractable, we're good to go. - (values (eq type1 *empty-type*) t)) + ;; This AVER causes problems if we write accurate methods for the + ;; union (and possibly intersection) types which then delegate to + ;; us; while a user shouldn't get here, because of the odd status of + ;; *wild-type* a type-intersection executed by the compiler can. - + ;; CSR, 2002-04-10 + ;; + ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type. + (cond ((eq type1 *empty-type*) + t) + (;; When TYPE2 might be the universal type in disguise + (type-might-contain-other-types-p type2) + ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods + ;; can delegate to us (more or less as CALL-NEXT-METHOD) when + ;; they're uncertain, we can't just barf on COMPOUND-TYPE and + ;; HAIRY-TYPEs as we used to. Instead we deal with the + ;; problem (where at least part of the problem is cases like + ;; (SUBTYPEP T '(SATISFIES FOO)) + ;; or + ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) + ;; where the second type is a hairy type like SATISFIES, or + ;; is a compound type which might contain a hairy type) by + ;; returning uncertainty. + (values nil nil)) + (t + ;; By elimination, TYPE1 is the universal type. + (aver (or (eq type1 *wild-type*) (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*))) + ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the + ;; universal type in disguise, TYPE2 is not a superset of TYPE1. + (values nil t)))) (!define-type-method (named :complex-subtypep-arg2) (type1 type2) - (assert (not (eq type2 *wild-type*))) ; * isn't really a type. + (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) ((hairy-type-p type1) - (values nil nil)) + (invoke-complex-subtypep-arg1-method type1 type2)) (t ;; FIXME: This seems to rely on there only being 2 or 3 - ;; HAIRY-TYPE values, and the exclusion of various + ;; NAMED-TYPE values, and the exclusion of various ;; possibilities above. It would be good to explain it and/or ;; rewrite it so that it's clearer. (values (not (eq type2 *empty-type*)) t)))) @@ -957,12 +1065,12 @@ (!define-type-method (named :complex-intersection2) (type1 type2) ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13. ;; Perhaps when bug 85 is fixed it can be reenabled. - ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (hierarchical-intersection2 type1 type2)) (!define-type-method (named :complex-union2) (type1 type2) ;; Perhaps when bug 85 is fixed this can be reenabled. - ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (hierarchical-union2 type1 type2)) (!define-type-method (named :unparse) (x) @@ -970,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))) @@ -992,18 +1101,139 @@ complement-type2))) (if intersection2 (values (eq intersection2 *empty-type*) t) - (values nil nil)))) + (invoke-complex-subtypep-arg1-method type1 type2)))) (t - (values nil nil))))) + (invoke-complex-subtypep-arg1-method type1 type2))))) + +(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2) + ;; "Incrementally extended heuristic algorithms tend inexorably toward the + ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt + (let ((hairy-spec (hairy-type-specifier type1))) + (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not)) + ;; You may not believe this. I couldn't either. But then I + ;; sat down and drew lots of Venn diagrams. Comments + ;; involving a and b refer to the call (subtypep '(not a) + ;; 'b) -- CSR, 2002-02-27. + (block nil + ;; (Several logical truths in this block are true as + ;; long as b/=T. As of sbcl-0.7.1.28, it seems + ;; impossible to construct a case with b=T where we + ;; actually reach this type method, but we'll test for + ;; and exclude this case anyway, since future + ;; maintenance might make it possible for it to end up + ;; in this code.) + (multiple-value-bind (equal certain) + (type= type2 (specifier-type t)) + (unless certain + (return (values nil nil))) + (when equal + (return (values t t)))) + (let ((complement-type1 (specifier-type (cadr hairy-spec)))) + ;; Do the special cases first, in order to give us a + ;; chance if subtype/supertype relationships are hairy. + (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). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; KLUDGE: ANSI requires that the SUBTYPEP result + ;; between any two built-in atomic type specifiers + ;; never be uncertain. This is hard to do cleanly for + ;; the built-in types whose definitions include + ;; (NOT FOO), i.e. CONS and RATIO. However, we can do + ;; it with this hack, which uses our global knowledge + ;; that our implementation of the type system uses + ;; disjoint implementation types to represent disjoint + ;; sets (except when types are contained in other types). + ;; (This is a KLUDGE because it's fragile. Various + ;; changes in internal representation in the type + ;; system could make it start confidently returning + ;; incorrect results.) -- WHN 2002-03-08 + (unless (or (type-might-contain-other-types-p complement-type1) + (type-might-contain-other-types-p type2)) + ;; Because of the way our types which don't contain + ;; other types are disjoint subsets of the space of + ;; possible values, (SUBTYPEP '(NOT AA) 'B)=NIL when + ;; AA and B are simple (and B is not T, as checked above). + (return (values nil t))) + ;; The old (TYPE= TYPE1 TYPE2) branch would never be + ;; taken, as TYPE1 and TYPE2 will only be equal if + ;; they're both NOT types, and then the + ;; :SIMPLE-SUBTYPEP method would be used instead. + ;; But a CSUBTYPEP relationship might still hold: + (multiple-value-bind (equal certain) + (csubtypep complement-type1 type2) + ;; If a is a subtype of b, ~a is not a subtype of b + ;; (unless b=T, which was excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + (multiple-value-bind (equal certain) + (csubtypep type2 complement-type1) + ;; If b is a subtype of a, ~a is not a subtype of b. + ;; (FIXME: That's not true if a=T. Do we know at + ;; this point that a is not T?) + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; old CSR comment ca. 0.7.2, now obsoleted by the + ;; SIMPLE-CTYPE? KLUDGE case above: + ;; Other cases here would rely on being able to catch + ;; all possible cases, which the fragility of this + ;; type system doesn't inspire me; for instance, if a + ;; is type= to ~b, then we want T, T; if this is not + ;; the case and the types are disjoint (have an + ;; intersection of *empty-type*) then we want NIL, T; + ;; else if the union of a and b is the + ;; *universal-type* then we want T, T. So currently we + ;; still claim to be unsure about e.g. (subtypep '(not + ;; fixnum) 'single-float). + ))) + (t + (values nil nil))))) -(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2) +(!define-type-method (hairy :complex-=) (type1 type2) (declare (ignore type1 type2)) (values nil nil)) -(!define-type-method (hairy :simple-intersection2 :complex-intersection2) +(!define-type-method (hairy :simple-intersection2) (type1 type2) - (declare (ignore type1 type2)) - nil) + (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-union2) + (type1 type2) + (if (type= type1 type2) + type1 + nil)) + +(!define-type-method (hairy :complex-union2) + (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 (specifier-type (cadr hairy-type-spec)) type1) + *universal-type* + nil) + nil))) (!define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) @@ -1016,9 +1246,58 @@ ;; Check legality of arguments. (destructuring-bind (not typespec) whole (declare (ignore not)) - (specifier-type typespec)) ; must be legal typespec - ;; Create object. - (make-hairy-type :specifier whole)) + ;; must be legal 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))) + ((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-hairy-type :specifier whole)) + ;; FIXME: this is insufficiently general. We need to + ;; canonicalize over intersections and unions, too. However, + ;; this will probably suffice to get BIGNUM right, and more + ;; code will be written when someone (probably Paul Dietz) + ;; comes up with a test case that demonstrates a failure, + ;; because right now I can't construct one. + ((numeric-type-p not-type) + (type-union + ;; FIXME: so much effort for parsing? This seems overly + ;; compute-heavy. + (specifier-type `(not ,(type-specifier + (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) 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) l (list l))))) + (t (type-union + (modified-numeric-type + not-type + :low nil + :high (let ((l (numeric-type-low not-type))) + (if (consp l) l (list l)))) + (modified-numeric-type + not-type + :low (let ((h (numeric-type-high not-type))) + (if (consp h) h (list h))) + :high nil)))))) + (t (make-hairy-type :specifier whole)))))) (!def-type-translator satisfies (&whole whole fun) (declare (ignore fun)) @@ -1029,35 +1308,13 @@ (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)) ;;;; numeric types -#!+negative-zero-is-not-zero -(defun make-numeric-type (&key class format (complexp :real) low high - enumerable) - (flet ((canonicalise-low-bound (x) - ;; Canonicalise a low bound of (-0.0) to 0.0. - (if (and (consp x) (floatp (car x)) (zerop (car x)) - (minusp (float-sign (car x)))) - (float 0.0 (car x)) - x)) - (canonicalise-high-bound (x) - ;; Canonicalise a high bound of (+0.0) to -0.0. - (if (and (consp x) (floatp (car x)) (zerop (car x)) - (plusp (float-sign (car x)))) - (float -0.0 (car x)) - x))) - (%make-numeric-type :class class - :format format - :complexp complexp - :low (canonicalise-low-bound low) - :high (canonicalise-high-bound high) - :enumerable enumerable))) - (!define-type-class number) (!define-type-method (number :simple-=) (type1 type2) @@ -1090,8 +1347,8 @@ `(unsigned-byte ,high-length)) (t `(mod ,(1+ high))))) - ((and (= low sb!vm:*target-most-negative-fixnum*) - (= high sb!vm:*target-most-positive-fixnum*)) + ((and (= low sb!xc:most-negative-fixnum) + (= high sb!xc:most-positive-fixnum)) 'fixnum) ((and (= low (lognot high)) (= high-count high-length) @@ -1113,7 +1370,7 @@ 'complex `(complex ,base+bounds))) ((nil) - (assert (eq base+bounds 'real)) + (aver (eq base+bounds 'real)) 'number))))) ;;; Return true if X is "less than or equal" to Y, taking open bounds @@ -1241,7 +1498,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. @@ -1312,21 +1569,89 @@ >= > 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))) -(!def-type-translator complex (&optional (spec '*)) - (if (eq spec '*) +(!def-type-translator complex (&optional (typespec '*)) + (if (eq typespec '*) (make-numeric-type :complexp :complex) - (let ((type (specifier-type spec))) - (unless (numeric-type-p type) - (error "The component type for COMPLEX is not numeric: ~S" spec)) - (when (eq (numeric-type-complexp type) :complex) - (error "The component type for COMPLEX is complex: ~S" spec)) - (let ((res (copy-numeric-type type))) - (setf (numeric-type-complexp res) :complex) - res)))) + (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" + 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)))))) + (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)))) + (t + (multiple-value-bind (subtypep certainly) + (csubtypep ctype (specifier-type 'real)) + (if (and (not subtypep) certainly) + (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 + used for a COMPLEX component.~:@>" + typespec))))))))) ;;; If X is *, return NIL, otherwise return the bound, which must be a ;;; member of TYPE or a one-element list of a member of TYPE. @@ -1350,25 +1675,92 @@ (lb (if (consp l) (1+ (car l)) l)) (h (canonicalized-bound high 'integer)) (hb (if (consp h) (1- (car h)) h))) - (when (and hb lb (< hb lb)) - (error "Lower bound ~S is greater than upper bound ~S." l h)) - (make-numeric-type :class 'integer - :complexp :real - :enumerable (not (null (and l h))) - :low lb - :high hb))) + (if (and hb lb (< hb lb)) + ;; 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: + *empty-type* + (make-numeric-type :class 'integer + :complexp :real + :enumerable (not (null (and l h))) + :low lb + :high hb)))) (defmacro !def-bounded-type (type class format) `(!def-type-translator ,type (&optional (low '*) (high '*)) (let ((lb (canonicalized-bound low ',type)) (hb (canonicalized-bound high ',type))) - (unless (numeric-bound-test* lb hb <= <) - (error "Lower bound ~S is not less than upper bound ~S." low high)) - (make-numeric-type :class ',class :format ',format :low lb :high hb)))) + (if (not (numeric-bound-test* lb hb <= <)) + ;; as above, previously we did + ;; (error "Lower bound ~S is not less than upper bound ~S." low high)) + ;; but it is correct to do + *empty-type* + (make-numeric-type :class ',class + :format ',format + :low lb + :high hb))))) (!def-bounded-type rational rational nil) -(!def-bounded-type float float nil) -(!def-bounded-type real nil nil) + +;;; Unlike CMU CL, we represent the types FLOAT and REAL as +;;; UNION-TYPEs of more primitive types, in order to make +;;; type representation more unique, avoiding problems in the +;;; simplification of things like +;;; (subtypep '(or (single-float -1.0 1.0) (single-float 0.1)) +;;; '(or (real -1 7) (single-float 0.1) (single-float -1.0 1.0))) +;;; When we allowed REAL to remain as a separate NUMERIC-TYPE, +;;; it was too easy for the first argument to be simplified to +;;; '(SINGLE-FLOAT -1.0), and for the second argument to be simplified +;;; to '(OR (REAL -1 7) (SINGLE-FLOAT 0.1)) and then for the +;;; SUBTYPEP to fail (returning NIL,T instead of T,T) because +;;; the first argument can't be seen to be a subtype of any of the +;;; terms in the second argument. +;;; +;;; The old CMU CL way was: +;;; (!def-bounded-type float float nil) +;;; (!def-bounded-type real nil nil) +;;; +;;; FIXME: If this new way works for a while with no weird new +;;; problems, we can go back and rip out support for separate FLOAT +;;; and REAL flavors of NUMERIC-TYPE. The new way was added in +;;; sbcl-0.6.11.22, 2001-03-21. +;;; +;;; 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) + (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)) +(!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))))) +(!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)) + #!+long-float ,(error "stub: no long float support yet")))) (defmacro !define-float-format (f) `(!def-bounded-type ,f float ,f)) @@ -1454,7 +1846,7 @@ nil)) ;;; Handle the case of type intersection on two numeric types. We use -;;; TYPES-INTERSECT to throw out the case of types with no +;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no ;;; intersection. If an attribute in TYPE1 is unspecified, then we use ;;; TYPE2's attribute, which must be at least as restrictive. If the ;;; types intersect, then the only attributes that can be specified @@ -1575,13 +1967,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)) @@ -1678,8 +2080,8 @@ ;; See whether dimensions are compatible. (cond ((not (or (eq dims1 '*) (eq dims2 '*) (and (= (length dims1) (length dims2)) - (every #'(lambda (x y) - (or (eq x '*) (eq y '*) (= x y))) + (every (lambda (x y) + (or (eq x '*) (eq y '*) (= x y))) dims1 dims2)))) (values nil t)) ;; See whether complexpness is compatible. @@ -1687,10 +2089,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))) @@ -1748,9 +2168,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)) @@ -1766,7 +2187,8 @@ ;;; subtype of the MEMBER type. (!define-type-method (member :complex-subtypep-arg2) (type1 type2) (cond ((not (type-enumerable type1)) (values nil t)) - ((types-intersect type1 type2) (values nil nil)) + ((types-equal-or-intersect type1 type2) + (invoke-complex-subtypep-arg1-method type1 type2)) (t (values nil t)))) (!define-type-method (member :simple-intersection2) (type1 type2) @@ -1781,7 +2203,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) @@ -1822,8 +2244,17 @@ (!def-type-translator member (&rest members) (if members - (make-member-type :members (remove-duplicates members)) - *empty-type*)) + (let (ms numbers) + (dolist (m (remove-duplicates members)) + (typecase m + (number (push (ctype-of m) numbers)) + (t (push m ms)))) + (apply #'type-union + (if ms + (make-member-type :members ms) + *empty-type*) + (nreverse numbers))) + *empty-type*)) ;;;; intersection types ;;;; @@ -1834,7 +2265,7 @@ ;;;; ;; reasonable definition ;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP))) ;;;; ;; reasonable behavior -;;;; (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL)) +;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL)) ;;;; Without understanding a little about the semantics of AND, we'd ;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely ;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's @@ -1850,7 +2281,7 @@ ;;; mechanically unparsed. (!define-type-method (intersection :unparse) (type) (declare (type ctype type)) - (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=) + (or (find type '(ratio keyword) :key #'specifier-type :test #'type=) `(and ,@(mapcar #'type-specifier (intersection-type-types type))))) ;;; shared machinery for type equality: true if every type in the set @@ -1877,20 +2308,71 @@ (type=-set (intersection-type-types type1) (intersection-type-types type2))) -(flet ((intersection-complex-subtypep-arg1 (type1 type2) - (any/type (swapped-args-fun #'csubtypep) - type2 - (intersection-type-types type1)))) - (!define-type-method (intersection :simple-subtypep) (type1 type2) - (every/type #'intersection-complex-subtypep-arg1 - type1 - (intersection-type-types type2))) - (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) - (intersection-complex-subtypep-arg1 type1 type2))) +(defun %intersection-complex-subtypep-arg1 (type1 type2) + (any/type (swapped-args-fun #'csubtypep) + type2 + (intersection-type-types type1))) -(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) +(defun %intersection-simple-subtypep (type1 type2) + (every/type #'%intersection-complex-subtypep-arg1 + type1 + (intersection-type-types type2))) + +(!define-type-method (intersection :simple-subtypep) (type1 type2) + (%intersection-simple-subtypep type1 type2)) + +(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) + (%intersection-complex-subtypep-arg1 type1 type2)) + +(defun %intersection-complex-subtypep-arg2 (type1 type2) (every/type #'csubtypep type1 (intersection-type-types type2))) +(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) + (%intersection-complex-subtypep-arg2 type1 type2)) + +;;; FIXME: This will look eeriely familiar to readers of the UNION +;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method. That's +;;; because it was generated by cut'n'paste methods. Given that +;;; intersections and unions have all sorts of symmetries known to +;;; mathematics, it shouldn't be beyond the ken of some programmers to +;;; reflect those symmetries in code in a way that ties them together +;;; more strongly than having two independent near-copies :-/ +(!define-type-method (intersection :simple-union2 :complex-union2) + (type1 type2) + ;; Within this method, type2 is guaranteed to be an intersection + ;; type: + (aver (intersection-type-p type2)) + ;; Make sure to call only the applicable methods... + (cond ((and (intersection-type-p type1) + (%intersection-simple-subtypep type1 type2)) type2) + ((and (intersection-type-p type1) + (%intersection-simple-subtypep type2 type1)) type1) + ((and (not (intersection-type-p type1)) + (%intersection-complex-subtypep-arg2 type1 type2)) + type2) + ((and (not (intersection-type-p type1)) + (%intersection-complex-subtypep-arg1 type2 type1)) + type1) + (t + (let ((accumulator *universal-type*)) + (dolist (t2 (intersection-type-types type2) accumulator) + (let ((union (type-union type1 t2))) + (when (union-type-p union) + ;; we give up here -- there are all sorts of ordering + ;; worries, but it's better than before. Doing + ;; exactly the same as in the UNION + ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack + ;; overflow with the mutual recursion never bottoming + ;; out. + (return nil)) + (setf accumulator + (type-intersection2 accumulator union)) + ;; When our result isn't simple any more (because + ;; TYPE-INTERSECTION2 was unable to give us a simple + ;; result) + (unless accumulator + (return nil)))))))) + (!def-type-translator and (&whole whole &rest type-specifiers) (apply #'type-intersection (mapcar #'specifier-type @@ -1900,48 +2382,108 @@ (!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) + ((type= type (specifier-type 'bignum)) 'bignum) + (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 +;;; methods are now more accurate; we don't get infinite recursion +;;; because the simple-subtypep method delegates to complex-subtypep +;;; of the individual types of type1. - CSR, 2002-04-09 +;;; +;;; Previous comment, now obsolete, but worth keeping around because +;;; it is true, though too strong a condition: +;;; ;;; Two union types are equal if their subtypes are equal sets. (!define-type-method (union :simple-=) (type1 type2) - (type=-set (union-type-types type1) - (union-type-types type2))) + (multiple-value-bind (subtype certain?) + (csubtypep type1 type2) + (if subtype + (csubtypep type2 type1) + ;; we might as well become as certain as possible. + (if certain? + (values nil t) + (multiple-value-bind (subtype certain?) + (csubtypep type2 type1) + (declare (ignore subtype)) + (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))) -;;; Similarly, a union type is a subtype of another if every element -;;; of TYPE1 is a subtype of some element of TYPE2. -;;; -;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and -;;; similarly in INTERSECTION-TYPE, with the logic in the -;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2 -;;; methods. Ideally there's probably some way to make the -;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO -;;; methods in such a way that this definition could go away, but I -;;; don't grok the system well enough to tell whether it's simple to -;;; arrange this. -- WHN 2000-02-03 -(!define-type-method (union :simple-subtypep) (type1 type2) - (dolist (t1 (union-type-types type1) (values t t)) - (multiple-value-bind (subtypep validp) - (union-complex-subtypep-arg2 t1 type2) - (cond ((not validp) - (return (values nil nil))) - ((not subtypep) - (return (values nil t))))))) +;;; Similarly, a union type is a subtype of another if and only if +;;; every element of TYPE1 is a subtype of TYPE2. +(defun union-simple-subtypep (type1 type2) + (every/type (swapped-args-fun #'union-complex-subtypep-arg2) + type2 + (union-type-types type1))) +(!define-type-method (union :simple-subtypep) (type1 type2) + (union-simple-subtypep type1 type2)) + (defun union-complex-subtypep-arg1 (type1 type2) (every/type (swapped-args-fun #'csubtypep) type2 (union-type-types type1))) + (!define-type-method (union :complex-subtypep-arg1) (type1 type2) (union-complex-subtypep-arg1 type1 type2)) (defun union-complex-subtypep-arg2 (type1 type2) - (any/type #'csubtypep type1 (union-type-types type2))) + (multiple-value-bind (sub-value sub-certain?) + ;; was: (any/type #'csubtypep type1 (union-type-types type2)), + ;; which turns out to be too restrictive, causing bug 91. + ;; + ;; the following reimplementation might look dodgy. It is + ;; dodgy. It depends on the union :complex-= method not doing + ;; very much work -- certainly, not using subtypep. Reasoning: + (progn + ;; At this stage, we know that type2 is a union type and type1 + ;; isn't. We might as well check this, though: + (aver (union-type-p type2)) + (aver (not (union-type-p type1))) + ;; A is a subset of (B1 u B2) + ;; <=> A n (B1 u B2) = A + ;; <=> (A n B1) u (A n B2) = A + ;; + ;; But, we have to be careful not to delegate this type= to + ;; something that could invoke subtypep, which might get us + ;; back here -> stack explosion. We therefore ensure that the + ;; second type (which is the one that's dispatched on) is + ;; either a union type (where we've ensured that the complex-= + ;; method will not call subtypep) or something with no union + ;; types involved, in which case we'll never come back here. + ;; + ;; If we don't do this, then e.g. + ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR))) + ;; would loop infinitely, as the member :complex-= method is + ;; implemented in terms of subtypep. + ;; + ;; Ouch. - CSR, 2002-04-10 + (type= type1 + (apply #'type-union + (mapcar (lambda (x) (type-intersection type1 x)) + (union-type-types type2))))) + (if sub-certain? + (values sub-value sub-certain?) + ;; The ANY/TYPE expression above is a sufficient condition for + ;; subsetness, but not a necessary one, so we might get a more + ;; certain answer by this CALL-NEXT-METHOD-ish step when the + ;; ANY/TYPE expression is uncertain. + (invoke-complex-subtypep-arg1-method type1 type2)))) + (!define-type-method (union :complex-subtypep-arg2) (type1 type2) (union-complex-subtypep-arg2 type1 type2)) @@ -1959,38 +2501,41 @@ ;; CSUBTYPEP, in order to avoid possibly invoking any methods which ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus ;; cause infinite recursion. - (cond ((union-complex-subtypep-arg2 type1 type2) + ;; + ;; Within this method, type2 is guaranteed to be a union type: + (aver (union-type-p type2)) + ;; Make sure to call only the applicable methods... + (cond ((and (union-type-p type1) + (union-simple-subtypep type1 type2)) type1) + ((and (union-type-p type1) + (union-simple-subtypep type2 type1)) type2) + ((and (not (union-type-p type1)) + (union-complex-subtypep-arg2 type1 type2)) type1) - ((union-complex-subtypep-arg1 type2 type1) + ((and (not (union-type-p type1)) + (union-complex-subtypep-arg1 type2 type1)) type2) (t + ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2 + ;; operations in a particular order, and gives up if any of + ;; the sub-unions turn out not to be simple. In other cases + ;; ca. sbcl-0.6.11.15, that approach to taking a union was a + ;; bad idea, since it can overlook simplifications which + ;; might occur if the terms were accumulated in a different + ;; order. It's possible that that will be a problem here too. + ;; However, I can't think of a good example to demonstrate + ;; it, and without an example to demonstrate it I can't write + ;; test cases, and without test cases I don't want to + ;; complicate the code to address what's still a hypothetical + ;; problem. So I punted. -- WHN 2001-03-20 (let ((accumulator *empty-type*)) (dolist (t2 (union-type-types type2) accumulator) (setf accumulator (type-union2 accumulator (type-intersection type1 t2))) - ;; When our result isn't simple any more - (when (or - ;; (TYPE-UNION2 couldn't find a sufficiently simple - ;; result, so we can't either.) - (null accumulator) - ;; (A result containing an intersection isn't - ;; sufficiently simple for us. FIXME: Maybe it - ;; should be sufficiently simple for us? - ;; UNION-TYPEs aren't supposed to be nested inside - ;; INTERSECTION-TYPEs, so if we punt with NIL, - ;; we're condemning the expression to become a - ;; HAIRY-TYPE. If it were possible for us to - ;; return an INTERSECTION-TYPE, then the - ;; INTERSECTION-TYPE-TYPES could be merged into - ;; the outer INTERSECTION-TYPE which may be under - ;; construction. E.g. if this function could - ;; return an intersection type, and the calling - ;; functions were smart enough to handle it, then - ;; we could simplify (AND (OR FIXNUM KEYWORD) - ;; SYMBOL) to KEYWORD, even though KEYWORD - ;; is an intersection type.) - (intersection-type-p accumulator)) + ;; When our result isn't simple any more (because + ;; TYPE-UNION2 was unable to give us a simple result) + (unless accumulator (return nil))))))) (!def-type-translator or (&rest type-specifiers) @@ -2003,8 +2548,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))) @@ -2089,7 +2638,7 @@ (multiple-value-bind (val win) (csubtypep x-type y-type) (unless win (return-from type-difference nil)) (when val (return)) - (when (types-intersect x-type y-type) + (when (types-equal-or-intersect x-type y-type) (return-from type-difference nil)))))) (let ((y-mem (find-if #'member-type-p y-types))) (when y-mem @@ -2106,15 +2655,80 @@ (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 + +;;; Does the type derived from compilation of an actual function +;;; definition satisfy declarations of a function's type? +(defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype) + (declare (type ctype defined-ftype declared-ftype)) + (flet ((is-built-in-class-function-p (ctype) + (and (built-in-class-p ctype) + (eq (built-in-class-%name ctype) 'function)))) + (cond (;; DECLARED-FTYPE could certainly be #; + ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)). + (is-built-in-class-function-p declared-ftype) + ;; In that case, any definition satisfies the declaration. + t) + (;; It's not clear whether or how DEFINED-FTYPE might be + ;; #, but it's not obviously + ;; invalid, so let's handle that case too, just in case. + (is-built-in-class-function-p defined-ftype) + ;; No matter what DECLARED-FTYPE might be, we can't prove + ;; that an object of type FUNCTION doesn't satisfy it, so + ;; we return success no matter what. + t) + (;; Otherwise both of them must be FUN-TYPE objects. + t + ;; FIXME: For now we only check compatibility of the return + ;; type, not argument types, and we don't even check the + ;; return type very precisely (as per bug 94a). It would be + ;; good to do a better job. Perhaps to check the + ;; compatibility of the arguments, we should (1) redo + ;; VALUES-TYPES-EQUAL-OR-INTERSECT as + ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to + ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE + ;; is a base class both of VALUES-TYPE and of FUN-TYPE.) + (values-types-equal-or-intersect + (fun-type-returns defined-ftype) + (fun-type-returns declared-ftype)))))) + +;;; This messy case of CTYPE for NUMBER is shared between the +;;; cross-compiler and the target system. +(defun ctype-of-number (x) + (let ((num (if (complexp x) (realpart x) x))) + (multiple-value-bind (complexp low high) + (if (complexp x) + (let ((imag (imagpart x))) + (values :complex (min num imag) (max num imag))) + (values :real num num)) + (make-numeric-type :class (etypecase num + (integer 'integer) + (rational 'rational) + (float 'float)) + :format (and (floatp num) (float-format-name num)) + :complexp complexp + :low low + :high high)))) -(!defun-from-collected-cold-init-forms !late-type-cold-init) +(locally + ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type + ;; checking for declarations in structure accessors. Otherwise we + ;; can get caught in a chicken-and-egg bootstrapping problem, whose + ;; symptom on x86 OpenBSD sbcl-0.pre7.37.flaky5.22 is an illegal + ;; instruction trap. I haven't tracked it down, but I'm guessing it + ;; has to do with setting LAYOUTs when the LAYOUT hasn't been set + ;; yet. -- WHN + (declare (optimize (safety 0))) + (!defun-from-collected-cold-init-forms !late-type-cold-init)) (/show0 "late-type.lisp end of file")