From: Christophe Rhodes Date: Mon, 3 Mar 2003 11:16:04 +0000 (+0000) Subject: 0.7.13.11: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3a8bfcb01abe4d8eeb9ef1343d623dbbf57c19d9;p=sbcl.git 0.7.13.11: Merge "type system insanity" (CSR sbcl-devel 2002-03-01) ... extend INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD to take return values for the case that no next method is found ... define and use (once!) equivalent logic for COMPLEX-= ... be more uncertain on intersections of class types, since we create them when we don't know enough to canonicalize ... various other cases demand more uncertainty, too (e.g. intersections involving HAIRY-TYPEs) No known failures inherent to the type system! --- diff --git a/src/code/class.lisp b/src/code/class.lisp index 7d9b77d..e93efb3 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -851,6 +851,21 @@ ;; uncertain, since a subclass of both might be defined nil))) +;;; KLUDGE: we need this because of the need to represent +;;; intersections of two classes, even when empty at a given time, as +;;; uncanonicalized intersections because of the possibility of later +;;; defining a subclass of both classes. The necessity for changing +;;; the default return value from SUBTYPEP to NIL, T if no alternate +;;; method is present comes about because, unlike the other places we +;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the +;;; like, classes are in their own hierarchy with no possibility of +;;; mixtures with other type classes. +(!define-type-method (sb!xc:class :complex-subtypep-arg2) (type1 class2) + (if (and (intersection-type-p type1) + (> (count-if #'class-p (intersection-type-types type1)) 1)) + (values nil nil) + (invoke-complex-subtypep-arg1-method type1 class2 nil t))) + (!define-type-method (sb!xc:class :unparse) (type) (class-proper-name type)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 88eb018..ad25264 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1011,6 +1011,23 @@ ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (eq type1 type2) t)) +(!define-type-method (named :complex-=) (type1 type2) + (cond + ((and (eq type2 *empty-type*) + (intersection-type-p type1) + ;; not allowed to be unsure on these... FIXME: keep the list + ;; of CL types that are intersection types once and only + ;; once. + (not (or (type= type1 (specifier-type 'ratio)) + (type= type1 (specifier-type 'keyword))))) + ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION + ;; STREAM) can get here. In general, we can't really tell + ;; whether these are equal to NIL or not, so + (values nil nil)) + ((type-might-contain-other-types-p type1) + (invoke-complex-=-other-method type1 type2)) + (t (values nil t)))) + (!define-type-method (named :simple-subtypep) (type1 type2) (aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) @@ -1053,7 +1070,9 @@ (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) - ((hairy-type-p type1) + ((type-might-contain-other-types-p type1) + ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in + ;; disguise. So we'd better delegate. (invoke-complex-subtypep-arg1-method type1 type2)) (t ;; FIXME: This seems to rely on there only being 2 or 3 @@ -2406,9 +2425,7 @@ (intersection-type-types type2))) (defun %intersection-complex-subtypep-arg1 (type1 type2) - (any/type (swapped-args-fun #'csubtypep) - type2 - (intersection-type-types type1))) + (type= type1 (type-intersection type1 type2))) (defun %intersection-simple-subtypep (type1 type2) (every/type #'%intersection-complex-subtypep-arg1 @@ -2542,8 +2559,7 @@ (!define-type-method (union :complex-=) (type1 type2) (declare (ignore type1)) - (if (some #'(lambda (x) (or (hairy-type-p x) - (negation-type-p x))) + (if (some #'type-might-contain-other-types-p (union-type-types type2)) (values nil nil) (values nil t))) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index be23b94..b703a60 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -280,11 +280,21 @@ ;;; when no next method exists. -- WHN 2002-04-07 ;;; ;;; (We miss CLOS! -- CSR and WHN) -(defun invoke-complex-subtypep-arg1-method (type1 type2) +(defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win) (let* ((type-class (type-class-info type1)) (method-fun (type-class-complex-subtypep-arg1 type-class))) (if method-fun (funcall (the function method-fun) type1 type2) - (values nil nil)))) + (values subtypep win)))) + +;;; KLUDGE: This function is dangerous, as its overuse could easily +;;; cause stack exhaustion through unbounded recursion. We only use +;;; it in one place; maybe it ought not to be a function at all? +(defun invoke-complex-=-other-method (type1 type2) + (let* ((type-class (type-class-info type1)) + (method-fun (type-class-complex-= type-class))) + (if method-fun + (funcall (the function method-fun) type2 type1) + (values nil t)))) (!defun-from-collected-cold-init-forms !type-class-cold-init) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index da143e3..2b89eeb 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -124,7 +124,12 @@ ;;; HAIRY domain. (assert-nil-t (subtypep 'atom 'cons)) (assert-nil-t (subtypep 'cons 'atom)) +;;; These two are desireable but not necessary for ANSI conformance; +;;; maintenance work on other parts of the system broke them in +;;; sbcl-0.7.13.11 -- CSR +#+nil (assert-nil-t (subtypep '(not list) 'cons)) +#+nil (assert-nil-t (subtypep '(not float) 'single-float)) (assert-t-t (subtypep '(not atom) 'cons)) (assert-t-t (subtypep 'cons '(not atom))) diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index fd8409e..c4b282a 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -199,4 +199,4 @@ (cons bignum single-float)) '(cons single-float single-float)))) (assert (subtypep '(cons integer single-float) - '(or (cons fixnum single-float) (cons bignum single-float)))) \ No newline at end of file + '(or (cons fixnum single-float) (cons bignum single-float)))) diff --git a/version.lisp-expr b/version.lisp-expr index c9af215..0adeaf6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.13.10" +"0.7.13.11"