Skip to content
Snippets Groups Projects
Commit 3279c041 authored by gerd's avatar gerd
Browse files

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*.
parent 869d007b
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -1380,6 +1380,12 @@
(setf (%instance-ref structure (dsd-index dsd)) new-value))))) (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 ;;; %Defstruct -- Internal
;;; ;;;
;;; Do miscellaneous (LOAD EVAL) time actions for the structure described by ;;; Do miscellaneous (LOAD EVAL) time actions for the structure described by
...@@ -1407,7 +1413,7 @@ ...@@ -1407,7 +1413,7 @@
(setq layout (%class-layout class)))) (setq layout (%class-layout class))))
(setf (find-class (dd-name info)) class) (setf (find-class (dd-name info)) class)
(unless (eq (dd-type info) 'funcallable-structure) (unless (eq (dd-type info) 'funcallable-structure)
(dolist (slot (dd-slots info)) (dolist (slot (dd-slots info))
(unless (or (dsd-inherited-p info slot) (unless (or (dsd-inherited-p info slot)
...@@ -1439,7 +1445,11 @@ ...@@ -1439,7 +1445,11 @@
:expected-type class :expected-type class
:format-control "Structure for copier is not a ~S:~% ~S" :format-control "Structure for copier is not a ~S:~% ~S"
:format-arguments (list class structure))) :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) (when (dd-doc info)
(setf (documentation (dd-name info) 'type) (dd-doc info))) (setf (documentation (dd-name info) 'type) (dd-doc info)))
......
...@@ -25,7 +25,7 @@ ...@@ -25,7 +25,7 @@
;;; ************************************************************************* ;;; *************************************************************************
(ext:file-comment (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. ;;; Bootstrapping the meta-braid.
...@@ -504,18 +504,18 @@ ...@@ -504,18 +504,18 @@
;;; case we construct either a STRUCTURE-CLASS or a CONDITION-CLASS ;;; case we construct either a STRUCTURE-CLASS or a CONDITION-CLASS
;;; for the corresponding KERNEL::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)) (flet ((ensure (metaclass &optional (slots nil slotsp))
(let* ((class (kernel::find-class name)) (let* ((class (kernel::find-class name))
(kernel-supers (kernel:%class-direct-superclasses class)) (kernel-supers (kernel:%class-direct-superclasses class))
(supers (mapcar #'kernel:%class-name kernel-supers))) (supers (mapcar #'kernel:%class-name kernel-supers)))
(if slotsp (if slotsp
(ensure-class-using-class (ensure-class-using-class
nil name :metaclass metaclass :name name existing-class name :metaclass metaclass :name name
:direct-superclasses supers :direct-superclasses supers
:direct-slots slots) :direct-slots slots)
(ensure-class-using-class (ensure-class-using-class
nil name :metaclass metaclass :name name existing-class name :metaclass metaclass :name name
:direct-superclasses supers)))) :direct-superclasses supers))))
(slot-initargs-from-structure-slotd (slotd) (slot-initargs-from-structure-slotd (slotd)
(let ((accessor (structure-slotd-accessor-symbol slotd))) (let ((accessor (structure-slotd-accessor-symbol slotd)))
...@@ -538,6 +538,15 @@ ...@@ -538,6 +538,15 @@
(t (t
(error "~@<~S is not the name of a class.~@:>" name))))) (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) (defun method-function-returning-nil (args next-methods)
(declare (ignore args next-methods)) (declare (ignore args next-methods))
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
(ext:file-comment (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 @@ ...@@ -41,6 +41,12 @@
(setq lisp::*setf-fdefinition-hook* (setq lisp::*setf-fdefinition-hook*
(delete (symbol-function sym) 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. ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.
(let ((wot (kernel::find-symbol "*FIND-CLASS*" "PCL"))) (let ((wot (kernel::find-symbol "*FIND-CLASS*" "PCL")))
(when (and wot (boundp wot)) (when (and wot (boundp wot))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment