faster FIND and POSITION on bit-vectors

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

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index acaf32b..05ac6e2 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -398,8 +398,12 @@
 
 (defvar *define-condition-hooks* nil)
 
+(defun %set-condition-report (name report)
+  (setf (condition-classoid-report (find-classoid name))
+        report))
+
 (defun %define-condition (name parent-types layout slots documentation
-                          report default-initargs all-readers all-writers
+                          default-initargs all-readers all-writers
                           source-location)
   (with-single-package-locked-error
       (:symbol name "defining ~A as a condition")
@@ -409,7 +413,6 @@
             source-location))
     (let ((class (find-classoid name)))
       (setf (condition-classoid-slots class) slots)
-      (setf (condition-classoid-report class) report)
       (setf (condition-classoid-default-initargs class) default-initargs)
       (setf (fdocumentation name 'type) documentation)
 
@@ -548,10 +551,10 @@
              (setq report
                    (if (stringp arg)
                        `#'(lambda (condition stream)
-                          (declare (ignore condition))
-                          (write-string ,arg stream))
+                            (declare (ignore condition))
+                            (write-string ,arg stream))
                        `#'(lambda (condition stream)
-                          (funcall #',arg condition stream))))))
+                            (funcall #',arg condition stream))))))
           (:default-initargs
            (do ((initargs (rest option) (cddr initargs)))
                ((endp initargs))
@@ -575,11 +578,15 @@
                               ',layout
                               (list ,@(slots))
                               ,documentation
-                              ,report
                               (list ,@default-initargs)
                               ',(all-readers)
                               ',(all-writers)
-                              (sb!c:source-location)))))))
+                              (sb!c:source-location))
+           ;; This needs to be after %DEFINE-CONDITION in case :REPORT
+           ;; is a lambda referring to condition slot accessors:
+           ;; they're not proclaimed as functions before it has run if
+           ;; we're under EVAL or loaded as source.
+           (%set-condition-report ',name ,report))))))
 \f
 ;;;; various CONDITIONs specified by ANSI
 
@@ -766,6 +773,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)
@@ -786,22 +796,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
 
@@ -1088,15 +1098,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
@@ -1704,11 +1705,14 @@ the usual naming convention (names like *FOO*) for special variables"
   (define-nil-returning-restart continue ()
     "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
   (define-nil-returning-restart store-value (value)
-    "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
-   none exists.")
+    "Transfer control and VALUE to a restart named STORE-VALUE, or
+return NIL if none exists.")
   (define-nil-returning-restart use-value (value)
-    "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
-   none exists."))
+    "Transfer control and VALUE to a restart named USE-VALUE, or
+return NIL if none exists.")
+  (define-nil-returning-restart print-unreadably ()
+    "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or
+return NIL if none exists."))
 
 ;;; single-stepping restarts