X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=253b76f7bc7c8b3af7fa037fedf41f6b4f65a4a1;hb=992e6a70a0cae3f6d43bdbba18f77306fdf10662;hp=32db3f77f42e5f7e50c3023b4297790f9feff46d;hpb=1831934a29eb9361472e4f49efbcd5398392a6b0;p=sbcl.git

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 32db3f7..253b76f 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -41,7 +41,7 @@
 
 (/show0 "condition.lisp 24")
 
-(def!struct (condition-classoid (:include slot-classoid)
+(def!struct (condition-classoid (:include classoid)
                                 (:constructor make-condition-classoid))
   ;; list of CONDITION-SLOT structures for the direct slots of this
   ;; class
@@ -391,6 +391,8 @@
         (lambda (new-value condition)
           (condition-writer-function condition new-value slot-name))))
 
+(defvar *define-condition-hooks* nil)
+
 (defun %define-condition (name parent-types layout slots documentation
                           report default-initargs all-readers all-writers
                           source-location)
@@ -440,7 +442,10 @@
                        (dolist (initarg (condition-slot-initargs slot) nil)
                          (when (functionp (getf e-def-initargs initarg))
                            (return t))))
-               (push slot (condition-classoid-hairy-slots class))))))))
+               (push slot (condition-classoid-hairy-slots class)))))))
+      (when (boundp '*define-condition-hooks*)
+        (dolist (fun *define-condition-hooks*)
+          (funcall fun class))))
     name))
 
 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
@@ -524,8 +529,8 @@
                      :initform-p ',initform-p
                      :documentation ',documentation
                      :initform
-                     ,(if (constantp initform)
-                          `',(eval initform)
+                     ,(if (sb!xc:constantp initform)
+                          `',(constant-form-value initform)
                           `#'(lambda () ,initform)))))))
 
       (dolist (option options)
@@ -548,8 +553,8 @@
              (let ((val (second initargs)))
                (setq default-initargs
                      (list* `',(first initargs)
-                            (if (constantp val)
-                                `',(eval val)
+                            (if (sb!xc:constantp val)
+                                `',(constant-form-value val)
                                 `#'(lambda () ,val))
                             default-initargs)))))
           (t