setf: pre-defined setf-expanders should handle multiple value places gracefully.

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

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index a2d690a..8c410d4 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -171,9 +171,11 @@
 ;;; The current code doesn't seem to quite match that.
 (def!method print-object ((x condition) stream)
   (if *print-escape*
-      (if (and (typep x 'simple-condition) (slot-boundp x 'format-control))
+      (if (and (typep x 'simple-condition) (slot-value x 'format-control))
           (print-unreadable-object (x stream :type t :identity t)
-            (format stream "~S" (simple-condition-format-control x)))
+            (write (simple-condition-format-control x)
+                   :stream stream
+                   :lines 1))
           (print-unreadable-object (x stream :type t :identity t)))
       ;; KLUDGE: A comment from CMU CL here said
       ;;   7/13/98 BUG? CPL is not sorted and results here depend on order of
@@ -589,18 +591,21 @@
 (define-condition style-warning (warning) ())
 
 (defun simple-condition-printer (condition stream)
-  (apply #'format
-         stream
-         (simple-condition-format-control condition)
-         (simple-condition-format-arguments condition)))
+  (let ((control (simple-condition-format-control condition)))
+    (if control
+        (apply #'format stream
+               control
+               (simple-condition-format-arguments condition))
+        (error "No format-control for ~S" condition))))
 
 (define-condition simple-condition ()
   ((format-control :reader simple-condition-format-control
                    :initarg :format-control
+                   :initform nil
                    :type format-control)
    (format-arguments :reader simple-condition-format-arguments
                      :initarg :format-arguments
-                     :initform '()
+                     :initform nil
                      :type list))
   (:report simple-condition-printer))
 
@@ -761,6 +766,9 @@
 (defun %report-reader-error (condition stream &key simple)
   (let* ((error-stream (stream-error-stream condition))
          (pos (file-position-or-nil-for-error error-stream)))
+    (when (and pos (plusp pos))
+      ;; FILE-POSITION is the next character -- error is at the previous one.
+      (decf pos))
     (let (lineno colno)
       (when (and pos
                  (< pos sb!xc:array-dimension-limit)
@@ -781,22 +789,22 @@
                             :element-type (stream-element-type
                                            error-stream))))
           (when (= pos (read-sequence string error-stream))
+            ;; Lines count from 1, columns from 0. It's stupid and traditional.
             (setq lineno (1+ (count #\Newline string))
-                  colno (- pos
-                           (or (position #\Newline string :from-end t) -1)
-                           1))))
+                  colno (- pos (or (position #\Newline string :from-end t) 0)))))
         (file-position-or-nil-for-error error-stream pos))
       (pprint-logical-block (stream nil)
-        (format stream
-                "~S ~@[at ~W ~]~
-                    ~@[(line ~W~]~@[, column ~W) ~]~
-                    on ~S"
-                (class-name (class-of condition))
-                pos lineno colno error-stream)
-        (when simple
-          (format stream ":~2I~_~?"
-                  (simple-condition-format-control condition)
-                  (simple-condition-format-arguments condition)))))))
+        (if simple
+            (apply #'format stream
+                   (simple-condition-format-control condition)
+                   (simple-condition-format-arguments condition))
+            (prin1 (class-name (class-of condition)) stream))
+        (format stream "~2I~@[~_~_~:{~:(~A~): ~S~:^, ~:_~}~]~_~_Stream: ~S"
+                (remove-if-not #'second
+                               (list (list :line lineno)
+                                     (list :column colno)
+                                     (list :file-position pos)))
+                error-stream)))))
 \f
 ;;;; special SBCL extension conditions
 
@@ -1009,22 +1017,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
@@ -1079,15 +1091,6 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
 (define-condition encapsulated-condition (condition)
   ((condition :initarg :condition :reader encapsulated-condition)))
 
-(define-condition values-type-error (type-error)
-  ()
-  (:report
-   (lambda (condition stream)
-     (format stream
-             "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
-             (type-error-datum condition)
-             (type-error-expected-type condition)))))
-
 ;;; KLUDGE: a condition for floating point errors when we can't or
 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably