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))