[Sbcl-commits] 1.0.46.38: tad more information PACKAGE-LOCK-VIOLATION conditions

[Nikodemus S. <nik...@ra...>]

1.0.46.38: tad more information PACKAGE-LOCK-VIOLATION conditions

 * Add the current *PACKAGE* when the error is signaled to the
   condition.

 * Now that SIMPLE-CONDITION :FORMAT-CONTROL defaults to NIL,
   PACKAGE-LOCK-VIOLATION can inherit from SIMPLE-CONDITION instead of
   definining its own FORMAT-CONTROL and FORMAT-ARGUMENTS slots.

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5222
diff -u -r1.5222 version.lisp-expr
--- version.lisp-expr	19 Mar 2011 14:31:29 -0000	1.5222
+++ version.lisp-expr	19 Mar 2011 14:32:06 -0000
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.46.37"
+"1.0.46.38"
Index: src/code/condition.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v
retrieving revision 1.112
diff -u -r1.112 condition.lisp
--- src/code/condition.lisp	19 Mar 2011 14:31:29 -0000	1.112
+++ src/code/condition.lisp	19 Mar 2011 14:32:06 -0000
@@ -1014,22 +1014,26 @@
 #!+sb-package-locks
 (progn

-(define-condition package-lock-violation (reference-condition package-error)
-  ((format-control :initform nil :initarg :format-control
-                   :reader package-error-format-control)
-   (format-arguments :initform nil :initarg :format-arguments
-                     :reader package-error-format-arguments))
+(define-condition package-lock-violation (package-error
+                                          reference-condition
+                                          simple-condition)
+  ((current-package :initform *package*
+                    :reader package-lock-violation-in-package))
   (:report
    (lambda (condition stream)
-     (let ((control (package-error-format-control condition)))
+     (let ((control (simple-condition-format-control condition))
+           (error-package (package-name (package-error-package condition)))
+           (current-package (package-name
(package-lock-violation-in-package condition))))
        (if control
            (apply #'format stream
-                  (format nil "~~@<Lock on package ~A violated when ~A.~~:@>"
-                          (package-name (package-error-package condition))
-                          control)
-                  (package-error-format-arguments condition))
-           (format stream "~@<Lock on package ~A violated.~:@>"
-                   (package-name (package-error-package condition)))))))
+                  (format nil "~~@<Lock on package ~A violated when
~A while in package ~A.~~:@>"
+                          error-package
+                          control
+                          current-package)
+                  (simple-condition-format-arguments condition))
+           (format stream "~@<Lock on package ~A violated while in
package ~A.~:@>"
+                   error-package
+                   current-package)))))
   ;; no :default-initargs -- reference-stuff provided by the
   ;; signalling form in target-package.lisp
   #!+sb-doc