X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=ae934684ebe9fd914bc30ab96e78dcbce114a9ff;hb=5369caf4d418065012b96af0d29c74d7851c04ff;hp=e704d5e29edd7fd1712df9596df5ff07896d5e54;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index e704d5e..ae93468 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -69,7 +69,7 @@
 (!defstruct-with-alternate-metaclass condition
   :slot-names (actual-initargs assigned-slots)
   :boa-constructor %make-condition-object
-  :superclass-name instance
+  :superclass-name t
   :metaclass-name condition-classoid
   :metaclass-constructor make-condition-classoid
   :dd-type structure)
@@ -391,11 +391,17 @@
         (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)
+                          report default-initargs all-readers all-writers
+                          source-location)
   (with-single-package-locked-error
       (:symbol name "defining ~A as a condition")
     (%compiler-define-condition name parent-types layout all-readers all-writers)
+    (sb!c:with-source-location (source-location)
+      (setf (layout-source-location layout)
+            source-location))
     (let ((class (find-classoid name)))
       (setf (condition-classoid-slots class) slots)
       (setf (condition-classoid-report class) report)
@@ -436,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)
@@ -564,7 +573,8 @@
                               ,report
                               (list ,@default-initargs)
                               ',(all-readers)
-                              ',(all-writers)))))))
+                              ',(all-writers)
+                              (sb!c:source-location)))))))
 
 ;;;; DESCRIBE on CONDITIONs
 
@@ -825,6 +835,9 @@
      (format stream ", ")
      (destructuring-bind (type data) (cdr reference)
        (ecase type
+         (:initialization
+          (format stream "Initialization of ~:(~A~) Metaobjects"
+                  (substitute #\  #\- (symbol-name data))))
          (:generic-function (format stream "Generic Function ~S" data))
          (:section (format stream "Section ~{~D~^.~}" data)))))
     (:ansi-cl
@@ -873,6 +886,15 @@
                      (duplicate-definition-name c))))
   (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
 
+(define-condition constant-modified (reference-condition warning)
+  ((fun-name :initarg :fun-name :reader constant-modified-fun-name))
+  (:report (lambda (c s)
+             (format s "~@<Destructive function ~S called on ~
+                        constant data.~@:>"
+                     (constant-modified-fun-name c))))
+  (:default-initargs :references (list '(:ansi-cl :special-operator quote)
+                                       '(:ansi-cl :section (3 2 2 3)))))
+
 (define-condition package-at-variance (reference-condition simple-warning)
   ()
   (:default-initargs :references (list '(:ansi-cl :macro defpackage))))