Skip to content
Snippets Groups Projects
Commit dac93106 authored by toy's avatar toy
Browse files

Fix for the Entomotomy bug

atom-type-not-completely-understood-by-subtypep

This is ported from the fix used by SBCL.
parent eea4908a
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -1032,6 +1032,8 @@
(t (t
(values nil nil))))) (values nil nil)))))
;; We leave this here for posterity
#+nil
(define-type-method (hairy :complex-subtypep-arg1) (type1 type2) (define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
(let ((hairy-spec (hairy-type-specifier type1))) (let ((hairy-spec (hairy-type-specifier type1)))
(cond (cond
...@@ -1045,6 +1047,77 @@ ...@@ -1045,6 +1047,77 @@
(t (t
(values nil nil))))) (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) (define-type-method (hairy :complex-=) (type1 type2)
(declare (ignore type1 type2)) (declare (ignore type1 type2))
(values nil nil)) (values nil nil))
...@@ -1063,9 +1136,21 @@ ...@@ -1063,9 +1136,21 @@
(values t t) (values t t)
(values nil nil))) (values nil nil)))
#+nil
(def-type-translator not (&whole x type) (def-type-translator not (&whole x type)
(declare (ignore type)) (declare (ignore type))
(make-hairy-type :specifier x)) (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) (def-type-translator satisfies (&whole x fun)
(declare (ignore fun)) (declare (ignore fun))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment