0.8.0.2:

[sbcl.git] / src / pcl / defs.lisp

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 9b4bb43..dc12f84 100644 (file)
--- 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))
 
@@ -516,7 +520,20 @@
     :initform (cons nil nil))
    (predicate-name
     :initform nil
-    :reader class-predicate-name)))
+    :reader class-predicate-name)
+   (finalized-p
+    :initform nil
+    :reader class-finalized-p)))
+
+(def!method make-load-form ((class class) &optional env)
+  ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
+  ;; doesn't matter while all our environments are the same...
+  (declare (ignore env))
+  (let ((name (class-name class)))
+    (unless (and name (eq (find-class name nil) class))
+      (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
+            class))
+    `(find-class ',name)))
 
 ;;; The class PCL-CLASS is an implementation-specific common
 ;;; superclass of all specified subclasses of the class CLASS.
@@ -563,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
@@ -651,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
@@ -688,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)
   ())
@@ -822,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)