From 83e5661ae59addac315e6754013b3887b477570f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 19 May 2003 10:51:32 +0000 Subject: [PATCH] 0.8alpha.0.36: A little tender loving care, applied to conditions: ... make the implementation of DEFINE-CONDITION agree with the documentation string: allow :DOCUMENTATION slot options to work. ... ANSI (and pfdietz :-) wants SLOT-EXISTS-P to work on conditions; hook condition objects into CLOS enough to talk about existence of slots: (new classes CONDITION-{EFFECTIVE,DIRECT}-SLOT-DEFINITION, CONDITION-CLASS, etc) ... it's a bit ridiculous to have SLOT-EXISTS-P working on conditions, and then not be able to do SLOT-VALUE, so do the work necessary to make CONDITION objects more-or-less fully understood by PCL: (new methods on COMPUTE-SLOTS, ALLOCATE-INSTANCE, SLOT-VALUE-USING-CLASS and friends; new clauses in internal functions such as GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION; adjustment of the braid to set up CLOS knowledge of the new class hierarchy). --- NEWS | 9 +++ package-data-list.lisp-expr | 9 ++- src/code/condition.lisp | 13 ++++- src/pcl/braid.lisp | 69 ++++++++++++++++------- src/pcl/defs.lisp | 25 ++++++++- src/pcl/generic-functions.lisp | 2 + src/pcl/methods.lisp | 32 ++++++++--- src/pcl/slots-boot.lisp | 124 +++++++++++++++++++++++++---------------- src/pcl/slots.lisp | 33 +++++++++++ src/pcl/std-class.lisp | 62 ++++++++++++++++++++- version.lisp-expr | 2 +- 11 files changed, 298 insertions(+), 82 deletions(-) diff --git a/NEWS b/NEWS index 891ee6792..dadddb3d1 100644 --- a/NEWS +++ b/NEWS @@ -1720,6 +1720,13 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0 no longer has any effect, as the code controlled by this feature has been deleted. (As far as we know, no-one has ever built using this feature, and its semantics were confused in any case). + * minor incompatible change: as a consequence of making + SLOT-EXISTS-P work on conditions (as required by the ANSI + specification), SLOT-VALUE, (SETF SLOT-VALUE) and SLOT-BOUNDP + likewise have the expected behaviour on conditions. Users should + note, however, that such behaviour is not required by the ANSI + specification, and so use of this behaviour may render their code + unportable. * SB-MOP:DIRECT-SLOT-DEFINITION-CLASS and SB-MOP:EFFECTIVE-SLOT-DEFINITION-CLASS now have the specified-by-AMOP lambda list of (CLASS &REST INITARGS). @@ -1742,6 +1749,8 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0 ** ALLOCATE-INSTANCE now works on structure classes defined via DEFSTRUCT (and not just by those from DEFCLASS :METACLASS STRUCTURE-CLASS). + ** SLOT-EXISTS-P now works on conditions, as well as structures + and CLOS instances. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 51c54345c..54a7f278d 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1348,7 +1348,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH" "BUILT-IN-CLASSOID" - "CONDITION-CLASSOID-P" + "CONDITION-CLASSOID-P" "CONDITION-CLASSOID-SLOTS" "MAKE-UNDEFINED-CLASSOID" "FIND-CLASSOID" "CLASSOID" "CLASSOID-DIRECT-SUPERCLASSES" "MAKE-LAYOUT" "REDEFINE-LAYOUT-WARNING" "SLOT-CLASSOID" @@ -1361,6 +1361,13 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "NAMESTRING-PARSE-ERROR" "NAMESTRING-PARSE-ERROR-OFFSET" "DESCRIBE-CONDITION" + "CONDITION-READER-FUNCTION" "CONDITION-WRITER-FUNCTION" + + "CONDITION-SLOT-ALLOCATION" "CONDITION-SLOT-DOCUMENTATION" + "CONDITION-SLOT-INITARGS" "CONDITION-SLOT-INITFORM" + "CONDITION-SLOT-INITFORM-P" "CONDITION-SLOT-NAME" + "CONDITION-SLOT-READERS" "CONDITION-SLOT-WRITERS" + "!COLD-INIT" "!UNINTERN-INIT-ONLY-STUFF" "!GLOBALDB-COLD-INIT" "!FDEFN-COLD-INIT" "!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 5cdbc1aec..2633215a4 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -72,7 +72,9 @@ ;; allocation of this slot, or NIL until defaulted (allocation nil :type (member :instance :class nil)) ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value. - (cell nil :type (or cons null))) + (cell nil :type (or cons null)) + ;; slot documentation + (documentation nil :type (or string null))) ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed ;;; in its CPL, while other classes derived from CONDITION-CLASS don't @@ -428,6 +430,7 @@ (slot-name (first spec)) (allocation :instance) (initform-p nil) + documentation initform) (collect ((initargs) (readers) @@ -451,6 +454,13 @@ (:initarg (initargs arg)) (:allocation (setq allocation arg)) + (:documentation + (when documentation + (error "more than one :DOCUMENTATION in ~S" spec)) + (unless (stringp arg) + (error "slot :DOCUMENTATION argument is not a string: ~S" + arg)) + (setq documentation arg)) (:type) (t (error "unknown slot option:~% ~S" (first options)))))) @@ -463,6 +473,7 @@ :readers ',(readers) :writers ',(writers) :initform-p ',initform-p + :documentation ',documentation :initform ,(if (constantp initform) `',(eval initform) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index bd6e0efb9..e236279e9 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -120,6 +120,7 @@ slot-class-wrapper slot-class built-in-class-wrapper built-in-class structure-class-wrapper structure-class + condition-class-wrapper condition-class standard-direct-slot-definition-wrapper standard-direct-slot-definition standard-effective-slot-definition-wrapper @@ -128,7 +129,7 @@ standard-generic-function-wrapper standard-generic-function) (!initial-classes-and-wrappers standard-class funcallable-standard-class - slot-class built-in-class structure-class std-class + slot-class built-in-class structure-class condition-class std-class standard-direct-slot-definition standard-effective-slot-definition class-eq-specializer standard-generic-function) ;; First, make a class metaobject for each of the early classes. For @@ -144,7 +145,8 @@ (funcallable-standard-class funcallable-standard-class-wrapper) (built-in-class built-in-class-wrapper) - (structure-class structure-class-wrapper))) + (structure-class structure-class-wrapper) + (condition-class condition-class-wrapper))) (class (or (find-class name nil) (allocate-standard-instance wrapper)))) (setf (find-class name) class))) @@ -177,6 +179,8 @@ built-in-class-wrapper) ((eq class structure-class) structure-class-wrapper) + ((eq class condition-class) + condition-class-wrapper) ((eq class class-eq-specializer) class-eq-specializer-wrapper) ((eq class standard-generic-function) @@ -232,6 +236,11 @@ (!bootstrap-initialize-class meta class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper)) + (condition-class + (!bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper)))))))) (let* ((smc-class (find-class 'standard-method-combination)) @@ -292,7 +301,8 @@ ,@(and default-initargs `(default-initargs ,default-initargs)))) (when (memq metaclass-name '(standard-class funcallable-standard-class - structure-class slot-class std-class)) + structure-class condition-class + slot-class std-class)) (set-slot 'direct-slots direct-slots) (set-slot 'slots slots) (set-slot 'initialize-info nil)) @@ -312,21 +322,25 @@ (!bootstrap-set-slot metaclass-name super 'direct-subclasses (cons class subclasses)))))) - (if (eq metaclass-name 'structure-class) - (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) - (set-slot 'predicate-name (or (cadr (assoc name - *early-class-predicates*)) - (make-class-predicate-name name))) - (set-slot 'defstruct-form - `(defstruct (structure-object (:constructor - ,constructor-sym) - (:copier nil)))) - (set-slot 'defstruct-constructor constructor-sym) - (set-slot 'from-defclass-p t) - (set-slot 'plist nil) - (set-slot 'prototype (funcall constructor-sym))) - (set-slot 'prototype - (if proto-p proto (allocate-standard-instance wrapper)))) + (case metaclass-name + (structure-class + (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) + (set-slot 'predicate-name (or (cadr (assoc name + *early-class-predicates*)) + (make-class-predicate-name name))) + (set-slot 'defstruct-form + `(defstruct (structure-object (:constructor + ,constructor-sym) + (:copier nil)))) + (set-slot 'defstruct-constructor constructor-sym) + (set-slot 'from-defclass-p t) + (set-slot 'plist nil) + (set-slot 'prototype (funcall constructor-sym)))) + (condition-class + (set-slot 'prototype (make-condition name))) + (t + (set-slot 'prototype + (if proto-p proto (allocate-standard-instance wrapper))))) class)) (defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p) @@ -553,13 +567,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-slot (slot) + `(:name ,(condition-slot-name slot) + :initargs ,(condition-slot-initargs slot) + :readers ,(condition-slot-readers slot) + :writers ,(condition-slot-writers slot) + ,@(when (condition-slot-initform-p slot) + (let ((form-or-fun (condition-slot-initform slot))) + (if (functionp form-or-fun) + `(:initfunction ,form-or-fun) + `(:initform ,form-or-fun + :initfunction ,(lambda () form-or-fun))))) + :allocation (condition-slot-allocation slot) + :documentation (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)) + (ensure 'condition-class + (mapcar #'slot-initargs-from-condition-slot + (condition-classoid-slots (find-classoid name))))) (t (error "~@<~S is not the name of a class.~@:>" name))))) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index f11ff95b2..dc12f8469 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -102,6 +102,7 @@ *the-class-generic-function* *the-class-built-in-class* *the-class-slot-class* + *the-class-condition-class* *the-class-structure-class* *the-class-std-class* *the-class-standard-class* @@ -447,6 +448,9 @@ (defclass slot-object (t) () (:metaclass slot-class)) +(defclass condition (slot-object instance) () + (:metaclass condition-class)) + (defclass structure-object (slot-object instance) () (:metaclass structure-class)) @@ -576,7 +580,7 @@ (defclass built-in-class (pcl-class) ()) -(defclass condition-class (pcl-class) ()) +(defclass condition-class (slot-class) ()) (defclass structure-class (slot-class) ((defstruct-form @@ -664,6 +668,16 @@ :initarg :allocation-class :accessor slot-definition-allocation-class))) +(defclass condition-slot-definition (slot-definition) + ((allocation + :initform :instance + :initarg :allocation + :accessor slot-definition-allocation) + (allocation-class + :initform nil + :initarg :allocation-class + :accessor slot-definition-allocation-class))) + (defclass structure-slot-definition (slot-definition) ((defstruct-accessor-symbol :initform nil @@ -701,6 +715,14 @@ :initform nil :accessor slot-definition-location))) +(defclass condition-direct-slot-definition (condition-slot-definition + direct-slot-definition) + ()) + +(defclass condition-effective-slot-definition (condition-slot-definition + effective-slot-definition) + ()) + (defclass structure-direct-slot-definition (structure-slot-definition direct-slot-definition) ()) @@ -835,6 +857,7 @@ (std-class std-class-p) (standard-class standard-class-p) (funcallable-standard-class funcallable-standard-class-p) + (condition-class condition-class-p) (structure-class structure-class-p) (forward-referenced-class forward-referenced-class-p) (method method-p) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index be8ddec39..a66447c5f 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -14,6 +14,8 @@ (defgeneric classp (object)) +(defgeneric condition-class-p (object)) + (defgeneric eql-specializer-p (object)) (defgeneric exact-class-specializer-p (object)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 66d873ef4..5a57f2488 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -820,6 +820,9 @@ (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) (defvar *standard-slot-boundp-using-class-method* nil) +(defvar *condition-slot-value-using-class-method* nil) +(defvar *condition-setf-slot-value-using-class-method* nil) +(defvar *condition-slot-boundp-using-class-method* nil) (defvar *structure-slot-value-using-class-method* nil) (defvar *structure-setf-slot-value-using-class-method* nil) (defvar *structure-slot-boundp-using-class-method* nil) @@ -836,6 +839,18 @@ (writer (setq *standard-setf-slot-value-using-class-method* method)) (boundp (setq *standard-slot-boundp-using-class-method* method)))) +(defun condition-svuc-method (type) + (case type + (reader *condition-slot-value-using-class-method*) + (writer *condition-setf-slot-value-using-class-method*) + (boundp *condition-slot-boundp-using-class-method*))) + +(defun set-condition-svuc-method (type method) + (case type + (reader (setq *condition-slot-value-using-class-method* method)) + (writer (setq *condition-setf-slot-value-using-class-method* method)) + (boundp (setq *condition-slot-boundp-using-class-method* method)))) + (defun structure-svuc-method (type) (case type (reader *structure-slot-value-using-class-method*) @@ -854,17 +869,18 @@ (when (and (or (not (eq type 'writer)) (eq (pop specls) *the-class-t*)) (every #'classp specls)) - (cond ((and (eq (class-name (car specls)) - 'std-class) - (eq (class-name (cadr specls)) - 'std-object) + (cond ((and (eq (class-name (car specls)) 'std-class) + (eq (class-name (cadr specls)) 'std-object) (eq (class-name (caddr specls)) 'standard-effective-slot-definition)) (set-standard-svuc-method type method)) - ((and (eq (class-name (car specls)) - 'structure-class) - (eq (class-name (cadr specls)) - 'structure-object) + ((and (eq (class-name (car specls)) 'condition-class) + (eq (class-name (cadr specls)) 'condition) + (eq (class-name (caddr specls)) + 'condition-effective-slot-definition)) + (set-condition-svuc-method type method)) + ((and (eq (class-name (car specls)) 'structure-class) + (eq (class-name (cadr specls)) 'structure-object) (eq (class-name (caddr specls)) 'structure-effective-slot-definition)) (set-structure-svuc-method type method))))))) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 274d682de..6bd1e8b1b 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -130,29 +130,36 @@ t)) (defun get-optimized-std-accessor-method-function (class slotd name) - (if (structure-class-p class) - (ecase name - (reader (slot-definition-internal-reader-function slotd)) - (writer (slot-definition-internal-writer-function slotd)) - (boundp (make-structure-slot-boundp-function slotd))) - (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - ((std-class-p class) - ;; Shouldn't be using the optimized-std-accessors - ;; in this case. - #+nil (format t "* warning: ~S ~S~% ~S~%" - name slotd class) - nil) - (t (error "~S is not a STANDARD-CLASS." class)))) - (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) - (function (ecase name - (reader #'make-optimized-std-reader-method-function) - (writer #'make-optimized-std-writer-method-function) - (boundp #'make-optimized-std-boundp-method-function))) - (value (funcall function fsc-p slot-name index))) - (declare (type function function)) - (values value index)))) + (cond + ((structure-class-p class) + (ecase name + (reader (slot-definition-internal-reader-function slotd)) + (writer (slot-definition-internal-writer-function slotd)) + (boundp (make-structure-slot-boundp-function slotd)))) + ((condition-class-p class) + (ecase name + (reader (slot-definition-reader-function slotd)) + (writer (slot-definition-writer-function slotd)) + (boundp (slot-definition-boundp-function slotd)))) + (t + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + ((std-class-p class) + ;; Shouldn't be using the optimized-std-accessors + ;; in this case. + #+nil (format t "* warning: ~S ~S~% ~S~%" + name slotd class) + nil) + (t (error "~S is not a STANDARD-CLASS." class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function (ecase name + (reader #'make-optimized-std-reader-method-function) + (writer #'make-optimized-std-writer-method-function) + (boundp #'make-optimized-std-boundp-method-function))) + (value (funcall function fsc-p slot-name index))) + (declare (type function function)) + (values value index))))) (defun make-optimized-std-reader-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) @@ -236,31 +243,52 @@ (declare (ignore class object slotd)) t)) -(defun get-optimized-std-slot-value-using-class-method-function (class - slotd - name) - (if (structure-class-p class) - (ecase name - (reader (make-optimized-structure-slot-value-using-class-method-function - (slot-definition-internal-reader-function slotd))) - (writer (make-optimized-structure-setf-slot-value-using-class-method-function - (slot-definition-internal-writer-function slotd))) - (boundp (make-optimized-structure-slot-boundp-using-class-method-function))) - (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - (t (error "~S is not a standard-class" class)))) - (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) - (function - (ecase name - (reader - #'make-optimized-std-slot-value-using-class-method-function) - (writer - #'make-optimized-std-setf-slot-value-using-class-method-function) - (boundp - #'make-optimized-std-slot-boundp-using-class-method-function)))) - (declare (type function function)) - (values (funcall function fsc-p slot-name index) index)))) +(defun get-optimized-std-slot-value-using-class-method-function + (class slotd name) + (cond + ((structure-class-p class) + (ecase name + (reader (make-optimized-structure-slot-value-using-class-method-function + (slot-definition-internal-reader-function slotd))) + (writer (make-optimized-structure-setf-slot-value-using-class-method-function + (slot-definition-internal-writer-function slotd))) + (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))) + ((condition-class-p class) + (ecase name + (reader + (let ((fun (slot-definition-reader-function slotd))) + (declare (type function fun)) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))) + (writer + (let ((fun (slot-definition-writer-function slotd))) + (declare (type function fun)) + (lambda (new-value class object slotd) + (declare (ignore class slotd)) + (funcall fun new-value object)))) + (boundp + (let ((fun (slot-definition-boundp-function slotd))) + (declare (type function fun)) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))))) + (t + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + (t (error "~S is not a standard-class" class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function + (ecase name + (reader + #'make-optimized-std-slot-value-using-class-method-function) + (writer + #'make-optimized-std-setf-slot-value-using-class-method-function) + (boundp + #'make-optimized-std-slot-boundp-using-class-method-function)))) + (declare (type function function)) + (values (funcall function fsc-p slot-name index) index))))) (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slot-name index) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 786ce4bb5..a5bf11ba6 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -270,6 +270,35 @@ object) (defmethod slot-value-using-class + ((class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fun (slot-definition-reader-function slotd))) + (declare (type function fun)) + (funcall fun object))) + +(defmethod (setf slot-value-using-class) + (new-value + (class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fun (slot-definition-writer-function slotd))) + (declare (type function fun)) + (funcall fun new-value object))) + +(defmethod slot-boundp-using-class + ((class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fun (slot-definition-boundp-function slotd))) + (declare (type function fun)) + (funcall fun object))) + +(defmethod slot-makunbound-using-class ((class condition-class) object slot) + (error "attempt to unbind slot ~S in condition object ~S." + slot object)) + +(defmethod slot-value-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) @@ -337,3 +366,7 @@ (if constructor (funcall constructor) (error "can't allocate an instance of class ~S" (class-name class))))) + +(defmethod allocate-instance ((class condition-class) &rest initargs) + (declare (ignore initargs)) + (make-condition (class-name class))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 5ac26081b..b2d4cb7ae 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -606,12 +606,15 @@ (apply #'update-dependent class dependent initargs)))) (defmethod shared-initialize :after ((class condition-class) slot-names - &key direct-superclasses) + &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (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 (classoid-pcl-class classoid) class) (setq direct-supers direct-superclasses) @@ -620,7 +623,62 @@ (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)))) + ;; Comment from Gerd's PCL, 2003-05-15: + ;; + ;; We don't ADD-SLOT-ACCESSORS here because we don't want to + ;; override condition accessors with generic functions. We do this + ;; differently. + (update-pv-table-cache-info 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)) + (aver (slot-value class 'finalized-p)) + 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 (condition-reader-function x slot-name) + ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot + ;; is unbound; maybe it should be a CELL-ERROR of some + ;; sort? + (error () (slot-unbound class x slot-name))))) + (setf (slot-definition-writer-function slotd) + (lambda (v x) + (condition-writer-function x v slot-name))) + (setf (slot-definition-boundp-function slotd) + (lambda (x) + (multiple-value-bind (v c) + (ignore-errors (condition-reader-function x slot-name)) + (declare (ignore v)) + (null c)))) + slotd)) + +(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)))) + +(defmethod compute-slots :around ((class condition-class)) + (let ((eslotds (call-next-method))) + (mapc #'initialize-internal-slot-functions eslotds) + eslotds)) (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names &key diff --git a/version.lisp-expr b/version.lisp-expr index b1ac9ed7b..6f119f9ee 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8alpha.0.35" +"0.8alpha.0.36" -- 2.11.4.GIT