X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=dc12f8469dd5446933cee40be968c140fabc6ee3;hb=dbfe7e6c8b06e1b0b1ba35d9894fae13e6305602;hp=6882bf3fcaf168b57bfafdb6873fcfb2ac02647e;hpb=a736ac10b709b2d40305f0a6e3764afd246a8ef5;p=sbcl.git

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 6882bf3..dc12f84 100644
--- 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*
@@ -151,7 +152,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-standard-class (classoid-name type))))
 	((specializerp type) type)))
 
 ;;; interface
@@ -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,6 +580,8 @@
 
 (defclass built-in-class (pcl-class) ())
 
+(defclass condition-class (slot-class) ())
+
 (defclass structure-class (slot-class)
   ((defstruct-form
      :initform ()
@@ -649,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
@@ -686,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)
   ())
@@ -820,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)