From 3279c041dab0bcbb26b984c0aacda57fb2c66171 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sun, 30 Mar 2003 18:43:59 +0000
Subject: [PATCH] 	Update CLOS STRUCTURE-CLASSes on structure changes.

	* pcl/braid.lisp (ensure-non-standard-class): Add optional
	parameter existing-class.
	(reinitialize-structure-class): New function.
	(toplevel): Push it on kernel::*defstruct-hooks*.

	* code/defstruct.lisp (*defstruct-hooks*): New variable.
	(%defstruct): Call these hooks.

	* tools/pclcom.lisp (find-package): Remove
	pcl::reinitialize-structure-class from kernel::*defstruct-hooks*.
---
 code/defstruct.lisp | 16 +++++++++++++---
 pcl/braid.lisp      | 17 +++++++++++++----
 tools/pclcom.lisp   |  8 +++++++-
 3 files changed, 33 insertions(+), 8 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 0c545206c..42432d9d2 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.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/defstruct.lisp,v 1.83 2003/03/27 19:23:17 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.84 2003/03/30 18:43:59 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1380,6 +1380,12 @@
 	    (setf (%instance-ref structure (dsd-index dsd)) new-value)))))
 
 
+;;;
+;;; Used for updating CLOS structure classes.  Hooks are called
+;;; with one argument, the kernel::class.
+;;;
+(defvar *defstruct-hooks* nil)
+
 ;;; %Defstruct  --  Internal
 ;;;
 ;;;    Do miscellaneous (LOAD EVAL) time actions for the structure described by
@@ -1407,7 +1413,7 @@
 	   (setq layout (%class-layout class))))
 
     (setf (find-class (dd-name info)) class)
-
+    
     (unless (eq (dd-type info) 'funcallable-structure)
       (dolist (slot (dd-slots info))
 	(unless (or (dsd-inherited-p info slot)
@@ -1439,7 +1445,11 @@
 			   :expected-type class
 			   :format-control "Structure for copier is not a ~S:~% ~S"
 			   :format-arguments (list class structure)))
-		  (copy-structure structure))))))
+		  (copy-structure structure))))
+
+      (when (boundp '*defstruct-hooks*)
+	(dolist (fn *defstruct-hooks*)
+	  (funcall fn class)))))
 
   (when (dd-doc info)
     (setf (documentation (dd-name info) 'type) (dd-doc info)))
diff --git a/pcl/braid.lisp b/pcl/braid.lisp
index 0123e8074..72f82d74d 100644
--- a/pcl/braid.lisp
+++ b/pcl/braid.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.32 2003/03/30 13:42:06 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.33 2003/03/30 18:43:59 gerd Exp $")
 
 ;;;
 ;;; Bootstrapping the meta-braid.
@@ -504,18 +504,18 @@
 ;;; case we construct either a STRUCTURE-CLASS or a CONDITION-CLASS
 ;;; for the corresponding KERNEL::CLASS.
 ;;; 
-(defun ensure-non-standard-class (name)
+(defun ensure-non-standard-class (name &optional existing-class)
   (flet ((ensure (metaclass &optional (slots nil slotsp))
 	   (let* ((class (kernel::find-class name))
 		  (kernel-supers (kernel:%class-direct-superclasses class))
 		  (supers (mapcar #'kernel:%class-name kernel-supers)))
 	     (if slotsp
 		 (ensure-class-using-class
-		  nil name :metaclass metaclass :name name
+		  existing-class name :metaclass metaclass :name name
 		  :direct-superclasses supers
 		  :direct-slots slots)
 		 (ensure-class-using-class
-		  nil name :metaclass metaclass :name name
+		  existing-class name :metaclass metaclass :name name
 		  :direct-superclasses supers))))
 	 (slot-initargs-from-structure-slotd (slotd)
 	   (let ((accessor (structure-slotd-accessor-symbol slotd)))
@@ -538,6 +538,15 @@
 	  (t
 	   (error "~@<~S is not the name of a class.~@:>" name)))))
 
+(defun reinitialize-structure-class (kernel-class)
+  (let ((class (kernel:%class-pcl-class kernel-class)))
+    (when class 
+      (ensure-non-standard-class (class-name class) class))))
+
+(when (boundp 'kernel::*defstruct-hooks*)
+  (pushnew 'reinitialize-structure-class
+	   kernel::*defstruct-hooks*))
+
 
 (defun method-function-returning-nil (args next-methods)
   (declare (ignore args next-methods))
diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp
index fd9201f4c..47ec7fad6 100644
--- a/tools/pclcom.lisp
+++ b/tools/pclcom.lisp
@@ -3,7 +3,7 @@
 ;;; **********************************************************************
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.24 2003/03/22 16:15:14 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.25 2003/03/30 18:43:59 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -41,6 +41,12 @@
       (setq lisp::*setf-fdefinition-hook*
 	    (delete (symbol-function sym) lisp::*setf-fdefinition-hook*))))
 
+  (when (boundp 'kernel::*defstruct-hooks*)
+    (let ((sym (find-symbol "REINITIALIZE-STRUCTURE-CLASS" "PCL")))
+      (when sym
+	(setq kernel::*defstruct-hooks*
+	      (delete (symbol-function sym) kernel::*defstruct-hooks*)))))
+
   ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.
   (let ((wot (kernel::find-symbol "*FIND-CLASS*" "PCL")))
     (when (and wot (boundp wot))
-- 
GitLab