-** CONDITION-CLASS
-
-(find-class 'warning) gives an object of type STRUCTURE-CLASS.
-However, a WARNING is not a STRUCTURE-OBJECT, but a CONDITION-OBJECT,
-which contradicts the requirement that instances of STRUCTURE-CLASS be
-STRUCTURE-OBJECTs. Fix this, probably by teaching PCL about
-CONDITION-CLASS analogously to STRUCTURE-CLASS.
-
** CLASS-PROTOTYPE
[ fixed the (CLASS-PROTOTYPE (FIND-CLASS 'NULL)) issue; more general
** LEGAL-CLASS-NAME-P
-NIL is probably not a legal class name
+NIL is probably not a legal class name. Hmm, except that
+ (FIND-CLASS NIL NIL)
+still probably doesn't want to be an error (ASDF executes this
+internally, for a start).
+
+** DOCUMENTATION/DESCRIBE-OBJECT
+
+Can be done post-merge, but some of these methods talk about
+SB-KERNEL:CLASSOIDs rather than CL:CLASSes. Should be fixed to refer
+to user-relevant data, probably.
"%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH"
"BUILT-IN-CLASSOID"
+ "CONDITION-CLASSOID-P"
"MAKE-UNDEFINED-CLASSOID" "FIND-CLASSOID" "CLASSOID"
"CLASSOID-DIRECT-SUPERCLASSES" "MAKE-LAYOUT"
"REDEFINE-LAYOUT-WARNING" "SLOT-CLASSOID"
(defun wrapper-of (x)
(wrapper-of-macro x))
-(defvar *find-structure-class* nil)
-
(defun eval-form (form)
(lambda () (eval form)))
:initform ,(structure-slotd-init-form slotd)
:initfunction ,(eval-form (structure-slotd-init-form slotd))))
-(defun find-structure-class (symbol)
- (if (structure-type-p symbol)
- (unless (eq *find-structure-class* symbol)
- (let ((*find-structure-class* symbol))
- (ensure-class symbol
- :metaclass 'structure-class
- :name symbol
- :direct-superclasses
- (mapcar #'classoid-name
- (classoid-direct-superclasses
- (find-classoid symbol)))
- :direct-slots
- (mapcar #'slot-initargs-from-structure-slotd
- (structure-type-slot-description-list
- symbol)))))
- (error "~S is not a legal structure class name." symbol)))
+(defun ensure-non-standard-class (name)
+ (flet
+ ((ensure (metaclass &optional (slots nil slotsp))
+ (let ((supers
+ (mapcar #'classoid-name (classoid-direct-superclasses
+ (find-classoid name)))))
+ (if slotsp
+ (ensure-class-using-class name nil
+ :metaclass metaclass :name name
+ :direct-superclasses supers
+ :direct-slots slots)
+ (let ((supers (nsubstitute t 'instance supers)))
+ (ensure-class-using-class name nil
+ :metaclass metaclass :name name
+ :direct-superclasses supers))))))
+ (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))
+ (t
+ (error "~@<~S is not the name of a class.~@:>" name)))))
\f
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name))
(declaim (inline wrapper-class*))
(defun wrapper-class* (wrapper)
(or (wrapper-class wrapper)
- (find-structure-class
+ (ensure-non-standard-class
(classoid-name (layout-classoid wrapper)))))
;;; The wrapper cache machinery provides general mechanism for
(std (find-class 'std-class))
(standard (find-class 'standard-class))
(fsc (find-class 'funcallable-standard-class))
+ (condition (find-class 'condition-class))
(structure (find-class 'structure-class))
(built-in (find-class 'built-in-class)))
(flet ((specializer->metatype (x)
(if (eq *boot-state* 'complete)
(class-of (specializer-class x))
(class-of x))))
- (cond ((eq x *the-class-t*) t)
- ((*subtypep meta-specializer std)
- 'standard-instance)
- ((*subtypep meta-specializer standard)
- 'standard-instance)
- ((*subtypep meta-specializer fsc)
- 'standard-instance)
- ((*subtypep meta-specializer structure)
- 'structure-instance)
- ((*subtypep meta-specializer built-in)
- 'built-in-instance)
- ((*subtypep meta-specializer slot)
- 'slot-instance)
- (t (error "PCL cannot handle the specializer ~S (meta-specializer ~S)."
- new-specializer
- meta-specializer))))))
+ (cond
+ ((eq x *the-class-t*) t)
+ ((*subtypep meta-specializer std) 'standard-instance)
+ ((*subtypep meta-specializer standard) 'standard-instance)
+ ((*subtypep meta-specializer fsc) 'standard-instance)
+ ((*subtypep meta-specializer condition) 'condition-instance)
+ ((*subtypep meta-specializer structure) 'structure-instance)
+ ((*subtypep meta-specializer built-in) 'built-in-instance)
+ ((*subtypep meta-specializer slot) 'slot-instance)
+ (t (error "~@<PCL cannot handle the specializer ~S ~
+ (meta-specializer ~S).~@:>"
+ new-specializer
+ meta-specializer))))))
;; We implement the following table. The notation is
;; that X and Y are distinct meta specializer names.
;;
;; FIXME: do we still need this?
((and (null args) (typep type 'classoid))
(or (classoid-pcl-class type)
- (find-structure-class (classoid-name type))))
+ (ensure-non-structure-class (classoid-name type))))
((specializerp type) type)))
;;; interface
(defclass built-in-class (pcl-class) ())
+(defclass condition-class (pcl-class) ())
+
(defclass structure-class (slot-class)
((defstruct-form
:initform ()
(setf (info :type :documentation (class-name x)) new-value))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
- (if (structure-type-p x) ; Catch structures first.
+ (if (or (structure-type-p x) (condition-type-p x))
(setf (info :type :documentation x) new-value)
(let ((class (find-class x nil)))
(if class
;;; it needs a more mnemonic name. -- WHN 19991204
(defun structure-type-p (type)
(and (symbolp type)
+ (not (condition-type-p type))
(let ((classoid (find-classoid type nil)))
(and classoid
(typep (layout-info
(classoid-layout classoid))
'defstruct-description)))))
+
+(defun condition-type-p (type)
+ (and (symbolp type)
+ (condition-classoid-p (find-classoid type nil))))
\f
(/show "finished with early-low.lisp")
(defun find-class-from-cell (symbol cell &optional (errorp t))
(or (find-class-cell-class cell)
(and *create-classes-from-internal-structure-definitions-p*
- (structure-type-p symbol)
- (find-structure-class symbol))
+ (or (structure-type-p symbol) (condition-type-p symbol))
+ (ensure-non-standard-class symbol))
(cond ((null errorp) nil)
((legal-class-name-p symbol)
(error "There is no class named ~S." symbol))
(defun named-object-print-function (instance stream
&optional (extra nil extra-p))
- (print-unreadable-object (instance stream :type t :identity t)
+ (print-unreadable-object (instance stream :type t)
(if extra-p
(format stream
"~S ~:S"
(remf initargs :metaclass)
(loop (unless (remf initargs :direct-superclasses) (return)))
(loop (unless (remf initargs :direct-slots) (return)))
- (values meta
- (list* :direct-superclasses
- (and (neq supplied-supers unsupplied)
- (mapcar #'fix-super supplied-supers))
- :direct-slots
- (and (neq supplied-slots unsupplied) supplied-slots)
- initargs))))
+ (values
+ meta
+ (nconc
+ (when (neq supplied-supers unsupplied)
+ (list :direct-superclasses (mapcar #'fix-super supplied-supers)))
+ (when (neq supplied-slots unsupplied)
+ (list :direct-slots supplied-slots))))))
\f
-
(defmethod shared-initialize :after
((class std-class)
slot-names
(lambda (dependent)
(apply #'update-dependent class dependent initargs))))
+(defmethod shared-initialize :after ((class condition-class) slot-names
+ &key 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 (classoid-pcl-class classoid) class)
+ (setq direct-supers direct-superclasses)
+ (setq wrapper (classoid-layout classoid))
+ (setq class-precedence-list (compute-class-precedence-list class))
+ (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))))
+
(defmethod shared-initialize :after
((slotd structure-slot-definition) slot-names &key
(allocation :instance) allocation-class)
(class-name class))))))
(make-class-predicate class predicate-name)
(add-slot-accessors class direct-slots)))
-
+
(defmethod direct-slot-definition-class ((class structure-class) initargs)
(declare (ignore initargs))
(find-class 'structure-direct-slot-definition))
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.13.pcl-class.3"
+"0.7.13.pcl-class.4"