0.9.14.25:

	Fix bug (reported by Jasko on #lisp) regarding
	TYPEP on funcallable-standard-classes with accessors.
	... make a STANDARD-CLASSOID for funcallable-standard-classes,
		too, as they behave (wrt the type system) in the same
		way.
	... STD-CLASSOID is now useless; delete it.
	... simplify MAKE-PRELIMINARY-LAYOUT a bit, since MAKE-WRAPPER
		now does the right thing.

diff --git a/src/code/class.lisp b/src/code/class.lisp
index dcd40fe..dc0b524 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -939,11 +939,15 @@ NIL is returned when no such class exists."
 \f
 ;;;; PCL stuff
 
-(def!struct (std-classoid (:include classoid)
-                          (:constructor nil)))
-(def!struct (standard-classoid (:include std-classoid)
+;;; the CLASSOID that we use to represent type information for
+;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.  The type system
+;;; side does not need to distinguish between STANDARD-CLASS and
+;;; FUNCALLABLE-STANDARD-CLASS.
+(def!struct (standard-classoid (:include classoid)
                                (:constructor make-standard-classoid)))
-(def!struct (random-pcl-classoid (:include std-classoid)
+;;; a metaclass for miscellaneous PCL structure-like objects (at the
+;;; moment, only CTOR objects).
+(def!struct (random-pcl-classoid (:include classoid)
                                  (:constructor make-random-pcl-classoid)))
 \f
 ;;;; built-in classes

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index 7465081..cf62b49 100644 (file)
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -258,6 +258,7 @@
         (cond (owrap
                (layout-classoid owrap))
               ((or (*subtypep (class-of class) *the-class-standard-class*)
+                   (*subtypep (class-of class) *the-class-funcallable-standard-class*)
                    (typep class 'forward-referenced-class))
                (cond ((and *pcl-class-boot*
                            (eq (slot-value class 'name) *pcl-class-boot*))
@@ -272,7 +273,7 @@
                         (make-standard-classoid :pcl-class class
                                                 :name (and (symbolp name) name))))))
               (t
-               (make-random-pcl-classoid :pcl-class class))))))
+               (bug "Got to T branch in ~S" 'make-wrapper))))))
     (t
      (let* ((found (find-classoid (slot-value class 'name)))
             (layout (classoid-layout found)))

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index ed2d9b8..930dfd9 100644 (file)
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -83,8 +83,8 @@
   :slot-names (clos-slots name hash-code)
   :boa-constructor %make-pcl-funcallable-instance
   :superclass-name function
-  :metaclass-name random-pcl-classoid
-  :metaclass-constructor make-random-pcl-classoid
+  :metaclass-name standard-classoid
+  :metaclass-constructor make-standard-classoid
   :dd-type funcallable-structure
   ;; Only internal implementation code will access these, and these
   ;; accesses (slot readers in particular) could easily be a

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 553e17d..3acc5db 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -455,23 +455,14 @@
          ;; some class is forthcoming, because there are legitimate
          ;; questions one can ask of the type system, implemented in
          ;; terms of CLASSOIDs, involving forward-referenced classes. So.
-         (let ((classoid (or (let ((layout (slot-value class 'wrapper)))
-                               (when layout (layout-classoid layout)))
-                             #+nil
-                             (find-classoid name nil)
-                             (make-standard-classoid
-                              :name (if (symbolp name) name nil))))
-               (layout (make-wrapper 0 class)))
-           (setf (layout-classoid layout) classoid)
-           (setf (classoid-pcl-class classoid) class)
+         (let ((layout (make-wrapper 0 class)))
            (setf (slot-value class 'wrapper) layout)
            (let ((cpl (compute-preliminary-cpl class)))
              (setf (layout-inherits layout)
                    (order-layout-inherits
                     (map 'simple-vector #'class-wrapper
                          (reverse (rest cpl))))))
-           (register-layout layout :invalidate t)
-           (setf (classoid-layout classoid) layout))))
+           (register-layout layout :invalidate t))))
      (mapc #'make-preliminary-layout (class-direct-subclasses class)))))
 
 

diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index b7af0cf..a2c85ef 100644 (file)
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -489,15 +489,22 @@
 ;;; classes (including anonymous ones) and eql-specializers should be
 ;;; allowed to be specializers.
 (defvar *anonymous-class*
-  (make-instance 'standard-class 
+  (make-instance 'standard-class
                  :direct-superclasses (list (find-class 'standard-object))))
 (defvar *object-of-anonymous-class*
   (make-instance *anonymous-class*))
 (eval `(defmethod method-on-anonymous-class ((obj ,*anonymous-class*)) 41))
 (assert (eql (method-on-anonymous-class *object-of-anonymous-class*) 41))
-(eval `(defmethod method-on-anonymous-class 
-        ((obj ,(intern-eql-specializer *object-of-anonymous-class*))) 
+(eval `(defmethod method-on-anonymous-class
+        ((obj ,(intern-eql-specializer *object-of-anonymous-class*)))
         42))
 (assert (eql (method-on-anonymous-class *object-of-anonymous-class*) 42))
 \f
+;;; accessors can cause early finalization, which caused confusion in
+;;; the system, leading to uncompileable TYPEP problems.
+(defclass funcallable-class-for-typep ()
+  ((some-slot-with-accessor :accessor some-slot-with-accessor))
+  (:metaclass funcallable-standard-class))
+(compile nil '(lambda (x) (typep x 'funcallable-class-for-typep)))
+\f
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 96a42df..e0713f0 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.14.24"
+"0.9.14.25"