From 88455ffb108a461981a7a9c34ae1d94a53b7a464 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sat, 10 May 2003 19:09:02 +0000 Subject: [PATCH] SLOT-EXISTS-P is supposed to work on conditions. Detected by Paul Dietz. * src/pcl/std-class.lisp (class-direct-slots, class-slots) <condition-class>: Remove methods. (shared-initialize) <condition-class>: Initialize direct and effective slots. (direct-slot-definition-class, effective-slot-definition-class) (finalize-inheritance, shared-initialize) <condition-class>: New methods. * src/pcl/braid.lisp (ensure-non-standard-class): Pass slot initargs to ensure-class for condition classes. * src/pcl/defs.lisp (condition-class): Inherit from slot-class. (condition-slot-definition, condition-direct-slot-definition) (condition-effective-slot-definition): New classes. --- pcl/braid.lisp | 21 ++++++++++++++++++--- pcl/defs.lisp | 15 +++++++++++++-- pcl/std-class.lisp | 33 ++++++++++++++++++++++++++++----- 3 files changed, 59 insertions(+), 10 deletions(-) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 9dbd2c07d..8e7a78d18 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.35 2003/05/04 13:11:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.36 2003/05/10 19:09:02 gerd Exp $") ;;; ;;; Bootstrapping the meta-braid. @@ -529,13 +529,28 @@ ,(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)))))) + :initfunction ,(eval-form (structure-slotd-init-form slotd))))) + (slot-initargs-from-condition-slotd (slot) + `(:name ,(conditions::condition-slot-name slot) + :initargs ,(conditions::condition-slot-initargs slot) + :readers ,(conditions::condition-slot-readers slot) + :writers ,(conditions::condition-slot-writers slot) + ,@(when (conditions::condition-slot-initform-p slot) + (let ((form-or-fn (conditions::condition-slot-initform slot))) + (if (functionp form-or-fn) + `(:initfunction ,form-or-fn) + `(:initform ,form-or-fn)))) + :allocation ,(conditions::condition-slot-allocation slot) + :documentation ,(conditions::condition-slot-documentation slot)))) (cond ((structure-type-p name) (ensure 'structure-class (mapcar #'slot-initargs-from-structure-slotd (structure-type-slot-description-list name)))) ((condition-type-p name) - (ensure 'condition-class)) + (let ((class (kernel::find-class name))) + (ensure 'condition-class + (mapcar #'slot-initargs-from-condition-slotd + (conditions::condition-class-slots class))))) (t (error "~@<~S is not the name of a class.~@:>" name))))) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index a704827b2..9cc48ce05 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -535,7 +535,7 @@ :initform nil :initarg :from-defclass-p))) -(defclass condition-class (pcl-class) ()) +(defclass condition-class (slot-class) ()) (defclass specializer-with-object (specializer) ()) @@ -650,6 +650,9 @@ was inherited." :initarg :internal-writer-function :accessor slot-definition-internal-writer-function))) +(defclass condition-slot-definition (standard-slot-definition) + ()) + (defclass direct-slot-definition (slot-definition) ()) @@ -669,7 +672,7 @@ was inherited." (defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) - ((location ; nil, a fixnum, a cons: (slot-name . value) + ((location :initform nil :accessor slot-definition-location))) @@ -677,10 +680,18 @@ was inherited." direct-slot-definition) ()) +(defclass condition-direct-slot-definition (condition-slot-definition + direct-slot-definition) + ()) + (defclass structure-effective-slot-definition (structure-slot-definition effective-slot-definition) ()) +(defclass condition-effective-slot-definition (condition-slot-definition + effective-slot-definition) + ()) + (defclass method (metaobject) ()) (defclass standard-method (definition-source-mixin documentation-mixin diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 07eae65b5..f0eba8d9d 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.62 2003/05/08 17:29:03 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.63 2003/05/10 19:09:01 gerd Exp $") (in-package :pcl) @@ -1580,18 +1580,19 @@ ;;; ;;; Conditions ;;; -(defmethod class-direct-slots ((class condition-class)) ()) -(defmethod class-slots ((class condition-class)) ()) (defmethod class-default-initargs ((class condition-class)) ()) (defmethod class-direct-default-initargs ((class condition-class)) ()) (defmethod shared-initialize :after ((class condition-class) slot-names - &key direct-superclasses) + &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((kernel-class (kernel::find-class (class-name class)))) (with-slots (wrapper class-precedence-list prototype predicate-name (direct-supers direct-superclasses)) class + (setf (slot-value class 'direct-slots) + (mapcar (lambda (pl) (make-direct-slotd class pl)) + direct-slots)) (setf (slot-value class 'finalized-p) t) (setf (kernel:%class-pcl-class kernel-class) class) (setq direct-supers direct-superclasses) @@ -1600,5 +1601,27 @@ (setq prototype (make-condition (class-name class))) (add-direct-subclasses class direct-superclasses) (setq predicate-name (make-class-predicate-name (class-name class))) - (make-class-predicate class predicate-name)))) + (make-class-predicate class predicate-name) + (setf (slot-value class 'slots) (compute-slots class))))) +(defmethod direct-slot-definition-class + ((class condition-class) &rest initargs) + (declare (ignore initargs)) + (find-class 'condition-direct-slot-definition)) + +(defmethod effective-slot-definition-class + ((class condition-class) &rest initargs) + (declare (ignore initargs)) + (find-class 'condition-effective-slot-definition)) + +(defmethod finalize-inheritance ((class condition-class)) + nil) + +(defmethod compute-slots ((class condition-class)) + (mapcan (lambda (superclass) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class (slot-definition-name dslotd) (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class 'class-precedence-list)))) + -- GitLab