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).
** 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
"%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"
"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"
;; 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
(slot-name (first spec))
(allocation :instance)
(initform-p nil)
+ documentation
initform)
(collect ((initargs)
(readers)
(: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))))))
:readers ',(readers)
:writers ',(writers)
:initform-p ',initform-p
+ :documentation ',documentation
:initform
,(if (constantp initform)
`',(eval initform)
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
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
(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)))
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)
(!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))
,@(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))
(!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)
,(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)))))
*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*
(defclass slot-object (t) ()
(:metaclass slot-class))
+(defclass condition (slot-object instance) ()
+ (:metaclass condition-class))
+
(defclass structure-object (slot-object instance) ()
(:metaclass structure-class))
(defclass built-in-class (pcl-class) ())
-(defclass condition-class (pcl-class) ())
+(defclass condition-class (slot-class) ())
(defclass structure-class (slot-class)
((defstruct-form
: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
: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)
())
(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)
(defgeneric classp (object))
+(defgeneric condition-class-p (object))
+
(defgeneric eql-specializer-p (object))
(defgeneric exact-class-specializer-p (object))
(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)
(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*)
(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)))))))
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*)
(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)
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))
(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)))
(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)
(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
;;; 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"
projects / sbcl.git / commitdiff