From 3673ccf8861bc2fe0c08b0e3312f089773901d74 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sat, 10 May 2003 20:27:24 +0000 Subject: [PATCH] Make condition slots readable with SLOT-VALUE. * src/pcl/std-class.lisp (compute-effective-slot-definition) <condition-class>: New method. * src/pcl/slots.lisp (slot-makunbound-using-class) <condition-class>: New method. --- general-info/release-19a.txt | 3 +++ pcl/slots.lisp | 8 +++++++- pcl/std-class.lisp | 22 +++++++++++++++++++++- 3 files changed, 31 insertions(+), 2 deletions(-) diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt index e4855d586..3c090e758 100644 --- a/general-info/release-19a.txt +++ b/general-info/release-19a.txt @@ -93,6 +93,9 @@ New in this release: - ALLOCATE-INSTANCE working with structures defined with DEFSTRUCT. - With (DEFGENERIC FOO (&REST X &KEY)) (DEFMETHOD FOO (&REST X) X), (FOO 1) now signals an error. + - Condition slots can be read with SLOT-VALUE, written with + (SETF SLOT-VALUE), and checked with SLOT-BOUNDP. It's not + possible to SLOT-MAKUNBOUND them, though. * Improvements to Hemlock, the Emacs-like editor: diff --git a/pcl/slots.lisp b/pcl/slots.lisp index 3218a918c..829dbd288 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.21 2003/05/04 13:11:20 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.22 2003/05/10 20:27:23 gerd Exp $") ;;; (in-package :pcl) @@ -266,6 +266,12 @@ (object structure-object) (slotd structure-effective-slot-definition)) (error "Structure slots cannot be unbound.")) + + +(defmethod slot-makunbound-using-class ((class condition-class) object slot) + (declare (ignore object slot)) + (error "Condition slots cannot be unbound.")) + (defmethod slot-missing diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index f0eba8d9d..ca947a750 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.63 2003/05/10 19:09:01 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.64 2003/05/10 20:27:23 gerd Exp $") (in-package :pcl) @@ -1617,6 +1617,26 @@ (defmethod finalize-inheritance ((class condition-class)) nil) +(defmethod compute-effective-slot-definition + ((class condition-class) slot-name dslotds) + (let ((slotd (call-next-method))) + (setf (slot-definition-reader-function slotd) + (lambda (x) + (handler-case + (conditions::condition-reader-function x slot-name) + (error () (slot-unbound class x slot-name))))) + (setf (slot-definition-writer-function slotd) + (lambda (v x) + (conditions::condition-writer-function x v slot-name))) + (setf (slot-definition-boundp-function slotd) + (lambda (x) + (multiple-value-bind (v c) + (ignore-errors + (conditions::condition-reader-function x slot-name)) + (declare (ignore v)) + (null c)))) + slotd)) + (defmethod compute-slots ((class condition-class)) (mapcan (lambda (superclass) (mapcar (lambda (dslotd) -- GitLab