0.pre8.64:

	Fix FIND-CLASS of compiled-but-not-loaded structure classes
	... slightly sucky hook variable in %TARGET-DEFSTRUCT, to be
		used by PCL
	... ENSURE-NON-STANDARD-CLASS updated to cope with the
		possibility that a CLASSOID exists but the accessor
		functions aren't FBOUNDP.
	... (side benefit: redefinitions of structures are now reflected
		in PCL classes)
	... test for FIND-CLASS non-breakage.

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index ec62457..87aab71 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -142,6 +142,10 @@
 \f
 ;;;; target-only parts of the DEFSTRUCT top level code
 
+;;; A list of hooks designating functions of one argument, the
+;;; classoid, to be called when a defstruct is evaluated.
+(defvar *defstruct-hooks* nil)
+
 ;;; Catch attempts to mess up definitions of symbols in the CL package.
 (defun protect-cl (symbol)
   (/show0 "entering PROTECT-CL, SYMBOL=..")
@@ -236,6 +240,11 @@
     (setf (fdocumentation (dd-name dd) 'type)
          (dd-doc dd)))
 
+  ;; the BOUNDP test here is to get past cold-init.
+  (when (boundp '*defstruct-hooks*)
+    (dolist (fun *defstruct-hooks*)
+      (funcall fun (find-classoid (dd-name dd)))))
+  
   (/show0 "leaving %TARGET-DEFSTRUCT")
   (values))
 \f

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 0fc49bb..01886b9 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -527,29 +527,32 @@
 (defun eval-form (form)
   (lambda () (eval form)))
 
-(defun slot-initargs-from-structure-slotd (slotd)
-  `(:name ,(structure-slotd-name slotd)
-    :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd)
-    :internal-reader-function ,(structure-slotd-reader-function slotd)
-    :internal-writer-function ,(structure-slotd-writer-function slotd)
-    :type ,(or (structure-slotd-type slotd) t)
-    :initform ,(structure-slotd-init-form slotd)
-    :initfunction ,(eval-form (structure-slotd-init-form slotd))))
-
-(defun ensure-non-standard-class (name)
+(defun ensure-non-standard-class (name &optional existing-class)
   (flet
       ((ensure (metaclass &optional (slots nil slotsp))
         (let ((supers
                (mapcar #'classoid-name (classoid-direct-superclasses
                                         (find-classoid name)))))
           (if slotsp
-              (ensure-class-using-class nil name
+              (ensure-class-using-class existing-class name
                                         :metaclass metaclass :name name
                                         :direct-superclasses supers
                                         :direct-slots slots)
-              (ensure-class-using-class nil name
+              (ensure-class-using-class existing-class name
                                         :metaclass metaclass :name name
-                                        :direct-superclasses supers)))))
+                                        :direct-superclasses supers))))
+       (slot-initargs-from-structure-slotd (slotd)
+        (let ((accessor (structure-slotd-accessor-symbol slotd)))
+          `(:name ,(structure-slotd-name slotd)
+            :defstruct-accessor-symbol ,accessor
+            ,@(when (fboundp accessor)
+                `(:internal-reader-function
+                  (structure-slotd-reader-function slotd)
+                  :internal-writer-function
+                  ,(structure-slotd-writer-function slotd)))
+            :type ,(or (structure-slotd-type slotd) t)
+            :initform ,(structure-slotd-init-form slotd)
+            :initfunction ,(eval-form (structure-slotd-init-form slotd))))))
     (cond ((structure-type-p name)
           (ensure 'structure-class
                   (mapcar #'slot-initargs-from-structure-slotd
@@ -558,6 +561,13 @@
           (ensure 'condition-class))
          (t
           (error "~@<~S is not the name of a class.~@:>" name)))))
+
+(defun maybe-reinitialize-structure-class (classoid)
+  (let ((class (classoid-pcl-class classoid)))
+    (when class
+      (ensure-non-standard-class (class-name class) class))))
+
+(pushnew 'maybe-reinitialize-structure-class sb-kernel::*defstruct-hooks*)
 \f
 (defun make-class-predicate (class name)
   (let* ((gf (ensure-generic-function name))

diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp
index eea3feb..6d61de0 100644 (file)
--- a/tests/compiler-1.impure-cload.lisp
+++ b/tests/compiler-1.impure-cload.lisp
@@ -225,4 +225,12 @@
                        nil)
                '(444 #*0000)))
 
+(defstruct some-structure a)
+(eval-when (:compile-toplevel)
+  ;; in the big CLASS reorganization in pre8, this would fail with
+  ;; SOME-STRUCTURE-A is not FBOUNDP.  Fixed in 0.pre8.64
+  (find-class 'some-structure nil))
+(eval-when (:load-toplevel)
+  (assert (typep (find-class 'some-structure) 'class)))
+
 (sb-ext:quit :unix-status 104) ; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 0de56bf..0f5249c 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.63"
+"0.pre8.64"