0.7.2.7:
authorWilliam Harold Newman <william.newman@airmail.net>
Mon, 8 Apr 2002 22:00:38 +0000 (22:00 +0000)
committerWilliam Harold Newman <william.newman@airmail.net>
Mon, 8 Apr 2002 22:00:38 +0000 (22:00 +0000)
making SUBTYPEP work better on ATOM (which is tricky because
it contains a naughty NOT, and which CMU CL SUBTYPEP
mostly punted on in a way that ANSI forbids), in a way
inspired by but different from CSR "get atom subtype"
patch...
...Do CALL-NEXT-METHOD, more or less, when before UNION-TYPE's
COMPLEX-SUBTYPEP-ARG2 would return NIL NIL.
...reviewed all COMPLEX-SUBTYPEP-ARG1 methods adding defensive
code to handle the new TYPE2 args that they may see now
...hacked HAIRY-COMPLEX-SUBTYPEP-ARG1 type method so that it
understands that ATOM isn't a subtype of any built-in
type except T and ATOM itself
(After changes above, we can deal with most of the cases that
CSR's patch did, but not yet (SUBTYPEP 'ATOM NIL). I
posted the code to sbcl-devel, got the green flag from
CSR, and forged ahead.)
...factored out the CALL-NEXT-METHOD-ish logic used in the
UNION-TYPE COMPLEX-SUBTYPEP-ARG2 method so that it can
be used in other COMPLEX-SUBTYPEP-ARG2 methods
...used the CALL-NEXT-METHOD-ish logic not only for NAMED
(to deal with (SUBTYPEP 'ATOM NIL)) but also in other
COMPLEX-SUBTYPEP-ARG2 methods which looked as though
they could (or just might) benefit from it
...The precondition "this will never be called with a hairy
type as TYPE2" in !HAS-SUPERCLASSES-COMPLEX-SUBTYPEP-ARG1
is now broken. (It would've been easier to figure this
out if the precondition had been expressed as an
assertion instead of just a comment. Oh well...)
...The SATISFIES FBOUNDP types floating around (mostly in pprint)
aren't really very good types in the sense of ANSI CL,
because they're not in general fixed sets, but can
change with time, so when the compiler attempts
reasonable tests and optimziations on them, things
will get confused. So convert them to explicit calls
to FBOUNDP, and/or just punt them somehow.
...Factor out the "type can conceal other types" predicate
in general. (Replace FLET SIMPLE-CTYPE?, and various
expressions involving HAIRY-TYPE-P, with a
TYPE-MIGHT-CONTAIN-OTHER-TYPES? CTYPE slot accessor,
and set that slot for HAIRY and COMPOUND CTYPEs.)
...Since there's an extra slot in CTYPE, we need to change
+FASL-FILE-VERSION+ again.
(Remove ridiculous #+(OR SBCL CMU) in my local CLOCC "ANSI"
test cases :TYPE-LEGACY-405, :TYPE-LEGACY-410, and
:TYPE-LEGACY-437. Otherwise we *fail* those tests now
that we have ANSI behavior! What were the CLOCC guys
thinking??)
Now bug #58 is gone too. Cool!

BUGS
NEWS
src/code/coerce.lisp
src/code/cross-type.lisp
src/code/early-fasl.lisp
src/code/early-type.lisp
src/code/late-type.lisp
src/code/pprint.lisp
src/code/type-class.lisp
src/code/typedefs.lisp
tests/type.impure.lisp

diff --git a/BUGS b/BUGS
index c5172fa..502fd0b 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -324,15 +324,6 @@ WORKAROUND:
        c: SYMBOL-MACROLET should signal PROGRAM-ERROR if something
           it binds is declared SPECIAL inside.
 
-50:
-  type system errors reported by Peter Van Eynde July 25, 2000:
-       g: The type system [still] isn't all that smart about relationships
-          between hairy types. [The original example from PVE was
-          (SUBTYPEP 'CONS '(NOT ATOM)) => NIL, NIL, which was fixed
-          by CSR in sbcl-0.7.1.28, but there are still
-           plenty of corner cases out there: (SUBTYPEP 'ATOM 'LIST)
-           returns NIL, NIL in sbcl-0.7.1.31.]
-
 51:
   miscellaneous errors reported by Peter Van Eynde July 25, 2000:
        a: (PROGN
@@ -1281,6 +1272,15 @@ WORKAROUND:
   but it has happened in more complicated cases (which I haven't
   figured out how to reproduce).
 
+155:
+  Executing 
+    (defclass standard-gadget (basic-gadget) ())
+    (defclass basic-gadget () ())
+  gives an error:
+    The slot SB-PCL::DIRECT-SUPERCLASSES is unbound in the
+    object #<SB-PCL::STANDARD-CLASS "unbound">.
+  (reported by Brian Spilsbury sbcl-devel 2002-04-09)
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.
diff --git a/NEWS b/NEWS
index c51dbde..1f76c35 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1073,6 +1073,22 @@ changes in sbcl-0.7.3 relative to sbcl-0.7.2:
   * The user manual (in doc/) is formatted into HTML more nicely.
     (thanks to coreythomas)
 
+changes in sbcl-0.7.3 relative to sbcl-0.7.2:
+  * The system is smarter about SUBTYPEP relationships, especially
+    those involving NOT types (including types such as ATOM which are
+    represented internally using NOT types). Thus SUBTYPEP is less
+    likely to return (VALUES NIL NIL) in general, and in particular
+    bugs 58 and (the remaining bits of) bug 50 are fixed. (thanks to
+    Christophe Rhodes)
+  * The fasl file format has changed again, because the internal
+    representation of types now includes a new slot to support the new
+    SUBTYPEP-of-NOT-types logic.
+  * (not a change in the main branch of SBCL, but a related prototype
+    which can hopefully be merged into the main branch of SBCL in the
+    future:) Brian Spilsbury has produced a Unicode-enabled variant of
+    sbcl-0.7.0, available as a patch against sbcl-0.7.0 at
+      <http://designix.com.au/brian/SBCL/sbcl-0.7.0-unicode.p0.gz>.
+
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe
   later, it might impact TRACE. They both encapsulate functions, and
index 0d1dcff..98d0a29 100644 (file)
                    (not (fboundp object)))
           (error 'simple-type-error
                  :datum object
+                 ;; FIXME: SATISFIES FBOUNDP is a kinda bizarre broken
+                 ;; type specifier, since the set of values it describes
+                 ;; isn't in general constant in time. Maybe we could
+                 ;; find a better way of expressing this error? (Maybe
+                 ;; with the UNDEFINED-FUNCTION condition?)
                  :expected-type '(satisfies fboundp)
               :format-control "~S isn't fbound."
               :format-arguments (list object)))
index cfb1a78..c6be1fc 100644 (file)
             ;; Common Lisp. (Some array types are too, but they
             ;; were picked off earlier.)
             (target-type-is-in
-             '(bit character complex cons float function integer keyword
-                   list nil null number rational real signed-byte symbol t
-                   unsigned-byte))
+             '(atom bit character complex cons float function integer keyword
+               list nil null number rational real signed-byte symbol t
+               unsigned-byte))
             (values (typep host-object target-type) t))
            (;; Floating point types are guaranteed to correspond,
             ;; too, but less exactly.
index 2408b1a..c592247 100644 (file)
@@ -42,7 +42,7 @@
 ;;; versions which break binary compatibility. But it certainly should
 ;;; be incremented for release versions which break binary
 ;;; compatibility.
-(defconstant +fasl-file-version+ 26)
+(defconstant +fasl-file-version+ 27)
 ;;; (record of versions before 0.7.0 deleted in 0.7.1.41)
 ;;; 23 = sbcl-0.7.0.1 deleted no-longer-used EVAL-STACK stuff,
 ;;;      causing changes in *STATIC-SYMBOLS*.
@@ -51,6 +51,7 @@
 ;;; 25 = sbcl-0.7.1.41 (and immediately preceding versions, actually)
 ;;;      introduced new functions to check for control stack exhaustion
 ;;; 26 = sbcl-0.7.2.4 or so added :VARIABLE :MACRO-EXPANSION to INFO codes
+;;; 27 (2002-04-08) added MIGHT-CONTAIN-OTHER-TYPES? slot to CTYPE
 
 ;;; the conventional file extension for our fasl files
 (declaim (type simple-string *fasl-file-type*))
index 5e21ecf..2eea097 100644 (file)
 ;;; the original type spec.
 (defstruct (hairy-type (:include ctype
                                 (class-info (type-class-or-lose 'hairy))
-                                (enumerable t))
+                                (enumerable t)
+                                (might-contain-other-types? t))
                       (:copier nil)
                       #!+cmu (:pure nil))
-  ;; the Common Lisp type-specifier
+  ;; the Common Lisp type-specifier of the type we represent
   (specifier nil :type t))
 
 (!define-type-class hairy)
 
 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
-(defstruct (compound-type (:include ctype)
+(defstruct (compound-type (:include ctype
+                                   (might-contain-other-types? t))
                          (:constructor nil)
                          (:copier nil))
   (types nil :type list :read-only t))
index c24af81..85b2882 100644 (file)
 ;;; 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? 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).
    (frob t *universal-type*))
  (setf *universal-fun-type*
        (make-fun-type :wild-args t
-                          :returns *wild-type*)))
+                     :returns *wild-type*)))
 
 (!define-type-method (named :simple-=) (type1 type2)
   ;; FIXME: BUG 85: This assertion failed when I added it in
 
 (!define-type-method (named :complex-subtypep-arg1) (type1 type2)
   (aver (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..)
-  (aver (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))).
-  (aver (not (compound-type-p type2))) 
-  ;; Then, since TYPE2 is reasonably tractable, we're good to go.
-  (values (eq type1 *empty-type*) t))
+  (cond ((eq type1 *empty-type*)
+        t)
+       (;; When TYPE2 might be the universal type in disguise
+        (type-might-contain-other-types? 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 (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)
   (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
                                                     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
                    (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
+               ;; 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? complement-type1)
+                           (type-might-contain-other-types? 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.
-               ;; ((type= type1 type2) (values t t))
+               ;; 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
                    (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).
+               ;; 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)))))
 ;;; subtype of the MEMBER type.
 (!define-type-method (member :complex-subtypep-arg2) (type1 type2)
   (cond ((not (type-enumerable type1)) (values nil t))
-       ((types-equal-or-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)
   (type=-set (union-type-types type1)
             (union-type-types type2)))
 
-;;; Similarly, a union type is a subtype of another if every element
-;;; of TYPE1 is a subtype of some element of TYPE2.
+;;; Similarly, a union type is a subtype of another if and only if
+;;; every element of TYPE1 is a subtype of TYPE2.
 (!define-type-method (union :simple-subtypep) (type1 type2)
   (every/type (swapped-args-fun #'union-complex-subtypep-arg2)
              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?) 
+      (any/type #'csubtypep type1 (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))
 
index 6ad9b5d..f28a76f 100644 (file)
   (defvar *precompiled-pprint-dispatch-funs*
     (list (frob (typep object 'array))
          (frob (and (consp object)
-                    (and (typep (car object) 'symbol)
-                         (typep (car object) '(satisfies fboundp)))))
+                    (symbolp (car object))
+                    (fboundp (car object))))
          (frob (typep object 'cons)))))
 
 (defun compute-test-fn (type)
     ;; printers for regular types
     (/show0 "doing SET-PPRINT-DISPATCH for regular types")
     (set-pprint-dispatch 'array #'pprint-array)
-    (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
+    (set-pprint-dispatch '(cons symbol)
                         #'pprint-fun-call -1)
     (set-pprint-dispatch 'cons #'pprint-fill -2)
     ;; cons cells with interesting things for the car
index 992d3e5..bf12bec 100644 (file)
   ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
   ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
   ;; have to be hand-tweaked to match. -- WHN 2001-03-19
-  (make-type-class :name                  (type-class-name x)
+  (make-type-class :name (type-class-name x)
                   . #.(mapcan (lambda (type-class-fun-slot)
                                 (destructuring-bind (keyword . slot-accessor)
                                     type-class-fun-slot
        (%invoke-type-method ',(class-fun-slot-or-lose simple)
                            ',(class-fun-slot-or-lose
                               (if complex-arg1-p
-                                complex-arg1
-                                complex-arg2))
+                                  complex-arg1
+                                  complex-arg2))
                            ',(class-fun-slot-or-lose complex-arg2)
                            ,complex-arg1-p
                            ,type1
                            ,type2)
      (if valid-p
-       (values result-a result-b)
-       ,default)))
+        (values result-a result-b)
+        ,default)))
 
 ;;; most of the implementation of !INVOKE-TYPE-METHOD
 ;;;
       (let ((class1 (type-class-info type1))
            (class2 (type-class-info type2)))
        (if (eq class1 class2)
-         (funcall (funcall simple class1) type1 type2)
-         (let ((complex2 (funcall cslot2 class2)))
-           (if complex2
-             (funcall complex2 type1 type2)
-             (let ((complex1 (funcall cslot1 class1)))
-               (if complex1
-                 (if complex-arg1-p
-                   (funcall complex1 type1 type2)
-                   (funcall complex1 type2 type1))
-                 ;; No meaningful result was found: the caller should
-                 ;; use the default value instead.
-                 (return-from %invoke-type-method (values nil nil nil))))))))
+           (funcall (funcall simple class1) type1 type2)
+           (let ((complex2 (funcall cslot2 class2)))
+             (if complex2
+                 (funcall complex2 type1 type2)
+                 (let ((complex1 (funcall cslot1 class1)))
+                   (if complex1
+                       (if complex-arg1-p
+                           (funcall complex1 type1 type2)
+                           (funcall complex1 type2 type1))
+                       ;; No meaningful result was found: the caller
+                       ;; should use the default value instead.
+                       (return-from %invoke-type-method
+                         (values nil nil nil))))))))
     ;; If we get to here (without breaking out by calling RETURN-FROM)
     ;; then a meaningful result was found, and we return it.
     (values result-a result-b t)))
 
+;;; This is a very specialized implementation of CLOS-style
+;;; CALL-NEXT-METHOD within our twisty little type class object
+;;; system, which works given that it's called from within a
+;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
+;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
+;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
+;;; so instead of just complacently returning (VALUES NIL NIL) from a
+;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
+;;;
+;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
+;;; everything would Just Work without us having to think about it. In
+;;; our goofy type dispatch system, it's messier to express. It's also
+;;; more fragile, since (0) there's no check that it's called from
+;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
+;;; rely on our global knowledge that the next (and only) relevant
+;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
+;;; knowledge of the appropriate default for the CSUBTYPEP function
+;;; when no next method exists. -- WHN 2002-04-07
+;;;
+;;; (We miss CLOS! -- CSR and WHN)
+(defun invoke-complex-subtypep-arg1-method (type1 type2)
+  (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))))
+
 (!defun-from-collected-cold-init-forms !type-class-cold-init)
index 36c8406..228d605 100644 (file)
   ;; (since EQ hashing can't be done portably)
   (hash-value (random (1+ most-positive-fixnum))
              :type (and fixnum unsigned-byte)
-             :read-only t))
+             :read-only t)
+  ;; Can this object contain other types? A global property of our
+  ;; implementation (which unfortunately seems impossible to enforce
+  ;; with assertions or other in-the-code checks and constraints) is
+  ;; that subclasses which don't contain other types correspond to
+  ;; disjoint subsets (except of course for the NAMED-TYPE T, which
+  ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is
+  ;; is disjoint from MEMBER-TYPE and so forth. But types which can
+  ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can
+  ;; violate this rule.
+  (might-contain-other-types? nil :read-only t))
 (def!method print-object ((ctype ctype) stream)
   (print-unreadable-object (ctype stream :type t)
     (prin1 (type-specifier ctype) stream)))
index 4b423bb..7a4e89e 100644 (file)
@@ -91,7 +91,7 @@
 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
 
 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
-#| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.6.11.10.
+#| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.7.2.
 (assert (raises-error? (typep 11 'and)))
 (assert (raises-error? (typep 11 'or)))
 |#
 (assert-nil-t (subtypep '(not float) 'single-float))
 (assert-t-t (subtypep '(not atom) 'cons))
 (assert-t-t (subtypep 'cons '(not atom)))
-;;; FIXME: Another thing to revisit is %INVOKE-TYPE-METHOD.
-;;; Essentially, the problem is that when the two arguments to
-;;; subtypep are of different specifier-type types (e.g. HAIRY and
-;;; UNION), there are two applicable type methods -- in this case
+;;; ANSI requires that SUBTYPEP relationships among built-in primitive
+;;; types never be uncertain, i.e. never return NIL as second value.
+;;; Prior to about sbcl-0.7.2.6, ATOM caused a lot of problems here
+;;; (because it's a negation type, implemented as a HAIRY-TYPE, and
+;;; CMU CL's HAIRY-TYPE logic punted a lot).
+(assert-t-t (subtypep 'integer 'atom))
+(assert-t-t (subtypep 'function 'atom))
+(assert-nil-t (subtypep 'list 'atom))
+(assert-nil-t (subtypep 'atom 'integer))
+(assert-nil-t (subtypep 'atom 'function))
+(assert-nil-t (subtypep 'atom 'list))
+;;; ATOM is equivalent to (NOT CONS):
+(assert-t-t (subtypep 'integer '(not cons)))
+(assert-nil-t (subtypep 'list '(not cons)))
+(assert-nil-t (subtypep '(not cons) 'integer))
+(assert-nil-t (subtypep '(not cons) 'list))
+;;; And we'd better check that all the named types are right. (We also
+;;; do some more tests on ATOM here, since once CSR experimented with
+;;; making it a named type.)
+(assert-t-t (subtypep 'nil 'nil))
+(assert-t-t (subtypep 'nil 'atom))
+(assert-t-t (subtypep 'nil 't))
+(assert-nil-t (subtypep 'atom 'nil))
+(assert-t-t (subtypep 'atom 'atom))
+(assert-t-t (subtypep 'atom 't))
+(assert-nil-t (subtypep 't 'nil))
+(assert-nil-t (subtypep 't 'atom))
+(assert-t-t (subtypep 't 't))
+;;; Also, LIST is now somewhat special, in that (NOT LIST) should be
+;;; recognized as a subtype of ATOM:
+(assert-t-t (subtypep '(not list) 'atom))
+(assert-nil-t (subtypep 'atom '(not list)))
+;;; These used to fail, because when the two arguments to subtypep are
+;;; of different specifier-type types (e.g. HAIRY and UNION), there
+;;; are two applicable type methods -- in this case
 ;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
-;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD.  Both of these exist, but
+;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD. Both of these exist, but
 ;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
 ;;; them returns NIL, NIL (indicating uncertainty) it should try the
-;;; other; this is complicated by the presence of other TYPE-METHODS
-;;; (e.g. INTERSECTION and UNION) whose return convention may or may
-;;; not follow the same standard.
-#||
+;;; other. However, as of sbcl-0.7.2.6 or so, CALL-NEXT-METHOD-ish
+;;; logic in those type methods fixed it.
 (assert-nil-t (subtypep '(not cons) 'list))
 (assert-nil-t (subtypep '(not single-float) 'float))
-||#
-;;; If we fix the above FIXME, we should for free have fixed bug 58.
-#||
+;;; Somewhere along the line (probably when adding CALL-NEXT-METHOD-ish
+;;; logic in SUBTYPEP type methods) we fixed bug 58 too:
 (assert-t-t (subtypep '(and zilch integer) 'zilch))
-||#
+(assert-t-t (subtypep '(and integer zilch) 'zilch))
+
 ;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
 ;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
 ;;; corresponding to the NIL type-specifier; we were bogusly returning