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. #<STANDARD-CLASS FOO> is enough, because there will
		only ever (we hope) be one standard-class named FOO.

diff --git a/TODO.pcl-class b/TODO.pcl-class
index 146f8f6..c196c1c 100644 (file)
--- 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 250739f..3c94145 100644 (file)
--- 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 60946a5..9a36654 100644 (file)
--- 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)))))
 \f
 (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 0106ba3..c3be109 100644 (file)
--- 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 "~@<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.
       ;;

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 6882bf3..19a1313 100644 (file)
--- 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 765f55c..9c562b3 100644 (file)
--- 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 4d2d116..abca534 100644 (file)
--- 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))))
 \f
 (/show "finished with early-low.lisp")

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index 3c98492..8dd2df7 100644 (file)
--- 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 2c6e71d..6a91b50 100644 (file)
--- 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 e6ab1cc..49aaa87 100644 (file)
--- 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))))))
 \f
-
 (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 d3a20e9..ed3eb8a 100644 (file)
--- 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"