X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=bd6e0efb93777d129934d31fd5be5c92c4b4503d;hb=5d0643d3b70aade43037e8b7cdf39b7e12f5d3fd;hp=b256c00e02e9fe8b51696d3f4848d3e320b91c74;hpb=80cc96cee0097619d3aab31244c0c3b8b32d3d0f;p=sbcl.git

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index b256c00..bd6e0ef 100644
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -261,6 +261,7 @@
 	 (set-slot (slot-name value)
 	   (!bootstrap-set-slot metaclass-name class slot-name value)))
     (set-slot 'name name)
+    (set-slot 'finalized-p t)
     (set-slot 'source source)
     (set-slot 'type (if (eq class (find-class t))
 			t
@@ -527,29 +528,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 name nil
+	       (ensure-class-using-class existing-class name
 					 :metaclass metaclass :name name
 					 :direct-superclasses supers
 					 :direct-slots slots)
-	       (ensure-class-using-class name nil
+	       (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 +562,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*)
 
 (defun make-class-predicate (class name)
   (let* ((gf (ensure-generic-function name))