diff --git a/code/type.lisp b/code/type.lisp index cc67bd01c94cbe81b41eab51c80911ea84e185de..a49621320cd916cc2bbf49f11b5b3ab5d3773ba1 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.42 2002/08/23 18:31:05 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.43 2002/10/16 18:35:14 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1032,6 +1032,8 @@ (t (values nil nil))))) +;; We leave this here for posterity +#+nil (define-type-method (hairy :complex-subtypep-arg1) (type1 type2) (let ((hairy-spec (hairy-type-specifier type1))) (cond @@ -1045,6 +1047,77 @@ (t (values nil nil))))) +;; This is the implementation used in SBCL. +(define-type-method (hairy :complex-subtypep-arg1) (type1 type2) + (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)))) + ;; This (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. + ;; ((type= type1 type2) (values t t)) + (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)))) + ;; 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-=) (type1 type2) (declare (ignore type1 type2)) (values nil nil)) @@ -1063,9 +1136,21 @@ (values t t) (values nil nil))) +#+nil (def-type-translator not (&whole x type) (declare (ignore type)) (make-hairy-type :specifier x)) +(def-type-translator not (&whole whole type) + (declare (ignore type)) + ;; Check legality of arguments. + (destructuring-bind (not typespec) whole + (declare (ignore not)) + (let ((spec (type-specifier (specifier-type typespec)))) ; must be legal typespec + (if (and (listp spec) (eq (car spec) 'not)) + ;; canonicalize (not (not foo)) + (specifier-type (cadr spec)) + (make-hairy-type :specifier whole))))) + (def-type-translator satisfies (&whole x fun) (declare (ignore fun))