From 95345bb533def44122ad6a1f61f06c3a0be3e9e3 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 21 Mar 2003 12:09:43 +0000 Subject: [PATCH] 0.7.13.pcl-class.4 Fix CONDITION-CLASS regression from ansi-tests ... many thanks to Gerd Moellmann ... delete dead *FIND-STRUCTURE-CLASS* variable ... some parallel code for CONDITION-CLASS(OID) stuff ... frob ENSURE-CLASS-VALUES slightly to ensure it doesn't automatically add on :DIRECT-SLOTS Go back to not printing IDENTITY for named objects ... i.e. # is enough, because there will only ever (we hope) be one standard-class named FOO. --- TODO.pcl-class | 19 ++++++++++--------- package-data-list.lisp-expr | 1 + src/pcl/braid.lisp | 41 +++++++++++++++++++++++------------------ src/pcl/cache.lisp | 32 +++++++++++++++----------------- src/pcl/defs.lisp | 4 +++- src/pcl/documentation.lisp | 2 +- src/pcl/early-low.lisp | 5 +++++ src/pcl/macros.lisp | 4 ++-- src/pcl/print-object.lisp | 2 +- src/pcl/std-class.lisp | 33 ++++++++++++++++++++++++--------- version.lisp-expr | 2 +- 11 files changed, 86 insertions(+), 59 deletions(-) diff --git a/TODO.pcl-class b/TODO.pcl-class index 146f8f6a9..c196c1c34 100644 --- a/TODO.pcl-class +++ b/TODO.pcl-class @@ -1,11 +1,3 @@ -** 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 @@ -19,4 +11,13 @@ conforming to AMOP. ** 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. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 250739f02..3c94145b5 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1342,6 +1342,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%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" diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 60946a541..9a3665433 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -524,8 +524,6 @@ (defun wrapper-of (x) (wrapper-of-macro x)) -(defvar *find-structure-class* nil) - (defun eval-form (form) (lambda () (eval form))) @@ -538,22 +536,29 @@ :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))))) (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name)) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 0106ba32a..c3be1091b 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -357,7 +357,7 @@ (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 @@ -610,6 +610,7 @@ (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) @@ -617,22 +618,19 @@ (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 "~@" + new-specializer + meta-specializer)))))) ;; We implement the following table. The notation is ;; that X and Y are distinct meta specializer names. ;; diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 6882bf3fc..19a131370 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -151,7 +151,7 @@ ;; 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 @@ -563,6 +563,8 @@ (defclass built-in-class (pcl-class) ()) +(defclass condition-class (pcl-class) ()) + (defclass structure-class (slot-class) ((defstruct-form :initform () diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index 765f55c5e..9c562b316 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -95,7 +95,7 @@ (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 diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index 4d2d1167b..abca53479 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -53,10 +53,15 @@ ;;; 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)))) (/show "finished with early-low.lisp") diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 3c984929e..8dd2df772 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -108,8 +108,8 @@ (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)) diff --git a/src/pcl/print-object.lisp b/src/pcl/print-object.lisp index 2c6e71d69..6a91b50c5 100644 --- a/src/pcl/print-object.lisp +++ b/src/pcl/print-object.lisp @@ -98,7 +98,7 @@ (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" diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index e6ab1ccef..49aaa87b3 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -443,15 +443,14 @@ (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)))))) - (defmethod shared-initialize :after ((class std-class) slot-names @@ -530,6 +529,22 @@ (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) @@ -653,7 +668,7 @@ (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)) diff --git a/version.lisp-expr b/version.lisp-expr index d3a20e9cb..ed3eb8a7b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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" -- 2.11.4.GIT