1.0.4.11: trivial hash-table cleanup / optimization

[sbcl.git] / src / code / condition.lisp

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 165fa06..098ec4e 100644 (file)
--- 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
@@ -830,9 +835,13 @@
      (format stream ", ")
      (destructuring-bind (type data) (cdr reference)
        (ecase type
+         (:readers "Readers for ~:(~A~) Metaobjects"
+                   (substitute #\  #\- (symbol-name data)))
          (:initialization
-          (format stream "Initialization of ~A Metaobjects" data))
+          (format stream "Initialization of ~:(~A~) Metaobjects"
+                  (substitute #\  #\- (symbol-name data))))
          (:generic-function (format stream "Generic Function ~S" data))
+         (:function (format stream "Function ~S" data))
          (:section (format stream "Section ~{~D~^.~}" data)))))
     (:ansi-cl
      (format stream "The ANSI Standard")
@@ -1161,6 +1170,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
 
 (define-condition step-condition ()
   ((form :initarg :form :reader step-condition-form))
+
   #!+sb-doc
   (:documentation "Common base class of single-stepping conditions.
 STEP-CONDITION-FORM holds a string representation of the form being
@@ -1171,8 +1181,18 @@ stepped."))
       "Form associated with the STEP-CONDITION.")
 
 (define-condition step-form-condition (step-condition)
-  ((source-path :initarg :source-path :reader step-condition-source-path)
-   (pathname :initarg :pathname :reader step-condition-pathname))
+  ((args :initarg :args :reader step-condition-args))
+  (:report
+   (lambda (condition stream)
+     (let ((*print-circle* t)
+           (*print-pretty* t)
+           (*print-readably* nil))
+       (format stream
+                 "Evaluating call:~%~<  ~@;~A~:>~%~
+                  ~:[With arguments:~%~{  ~S~%~}~;With unknown arguments~]~%"
+               (list (step-condition-form condition))
+               (eq (step-condition-args condition) :unknown)
+               (step-condition-args condition)))))
   #!+sb-doc
   (:documentation "Condition signalled by code compiled with
 single-stepping information when about to execute a form.
@@ -1206,13 +1226,14 @@ single-stepping information after executing a form.
 STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
 the values returned by the form as a list. No associated restarts."))
 
-(define-condition step-variable-condition (step-result-condition)
+(define-condition step-finished-condition (step-condition)
   ()
+  (:report
+   (lambda (condition stream)
+     (declare (ignore condition))
+     (format stream "Returning from STEP")))
   #!+sb-doc
-  (:documentation "Condition signalled by code compiled with
-single-stepping information when referencing a variable.
-STEP-CONDITION-FORM hold the symbol, and STEP-CONDITION-RESULT holds
-the value of the variable. No associated restarts."))
+  (:documentation "Condition signaled when STEP returns."))
 
 \f
 ;;;; restart definitions