diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 0c545206c4b701713781bca7f269da6fdcd8d085..42432d9d20bd7630018a5e24ca4fb0b8b747517a 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 0123e8074875f19c38ea69bf683aaca7308937fe..72f82d74d59e1c5eff28d41e5766a075a32f3673 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 fd9201f4cc67035aa589aa978fcc76b92bbb3e3e..47ec7fad62b091be20f439e0634ea9a267f543cf 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))