0.8.10.11:

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

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 4e686ef..699bb23 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -272,7 +272,10 @@
 ;;;; DEFINE-CONDITION
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-(defun %compiler-define-condition (name direct-supers layout)
+(defun %compiler-define-condition (name direct-supers layout
+                                  all-readers all-writers)
+  (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
+  (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
   (multiple-value-bind (class old-layout)
       (insured-find-classoid name
                             #'condition-classoid-p
@@ -313,7 +316,6 @@
          (remove-if-not #'condition-classoid-p 
                         (std-compute-class-precedence-list class))))
   (values))
-
 ) ; EVAL-WHEN
 
 ;;; Compute the effective slots of CLASS, copying inherited slots and
@@ -365,7 +367,9 @@
         (lambda (new-value condition)
           (condition-writer-function condition new-value slot-name))))
 
-(defun %define-condition (name slots documentation report default-initargs)
+(defun %define-condition (name parent-types layout slots documentation
+                         report default-initargs all-readers all-writers)
+  (%compiler-define-condition name parent-types layout all-readers all-writers)
   (let ((class (find-classoid name)))
     (setf (condition-classoid-slots class) slots)
     (setf (condition-classoid-report class) report)
@@ -522,17 +526,19 @@
           (error "unknown option: ~S" (first option)))))
 
       `(progn
-        (eval-when (:compile-toplevel :load-toplevel :execute)
-          (%compiler-define-condition ',name ',parent-types ',layout))
-
-        (declaim (ftype (function (t) t) ,@(all-readers)))
-        (declaim (ftype (function (t t) t) ,@(all-writers)))
-
-        (%define-condition ',name
-                           (list ,@(slots))
-                           ,documentation
-                           ,report
-                           (list ,@default-initargs))))))
+        (eval-when (:compile-toplevel)
+          (%compiler-define-condition ',name ',parent-types ',layout
+                                      ',(all-readers) ',(all-writers)))
+        (eval-when (:load-toplevel :execute)
+          (%define-condition ',name
+                             ',parent-types
+                             ',layout
+                             (list ,@(slots))
+                             ,documentation
+                             ,report
+                             (list ,@default-initargs)
+                             ',(all-readers)
+                             ',(all-writers)))))))
 \f
 ;;;; DESCRIBE on CONDITIONs
 
@@ -565,10 +571,12 @@
 
 (define-condition simple-condition ()
   ((format-control :reader simple-condition-format-control
-                  :initarg :format-control)
+                  :initarg :format-control
+                   :type format-control)
    (format-arguments :reader simple-condition-format-arguments
                     :initarg :format-arguments
-                    :initform '()))
+                    :initform '()
+                     :type list))
   (:report simple-condition-printer))
 
 (define-condition simple-warning (simple-condition warning) ())
@@ -675,11 +683,39 @@
     :initform '()))
   (:report
    (lambda (condition stream)
-     (let ((error-stream (stream-error-stream condition)))
-       (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?"
-              (file-position error-stream) error-stream
-              (reader-error-format-control condition)
-              (reader-error-format-arguments condition))))))
+     (let* ((error-stream (stream-error-stream condition))
+           (pos (file-position error-stream)))
+       (let (lineno colno)
+        (when (and pos
+                   (< pos sb!xc:array-dimension-limit)
+                   ;; KLUDGE: lseek() (which is what FILE-POSITION
+                   ;; reduces to on file-streams) is undefined on
+                   ;; "some devices", which in practice means that it
+                   ;; can claim to succeed on /dev/stdin on Darwin
+                   ;; and Solaris.  This is obviously bad news,
+                   ;; because the READ-SEQUENCE below will then
+                   ;; block, not complete, and the report will never
+                   ;; be printed.  As a workaround, we exclude
+                   ;; interactive streams from this attempt to report
+                   ;; positions.  -- CSR, 2003-08-21
+                   (not (interactive-stream-p error-stream))
+                   (file-position error-stream :start))
+          (let ((string
+                 (make-string pos
+                              :element-type (stream-element-type error-stream))))
+            (when (= pos (read-sequence string error-stream))
+              (setq lineno (1+ (count #\Newline string))
+                    colno (- pos
+                             (or (position #\Newline string :from-end t) -1)
+                             1))))
+          (file-position error-stream pos))
+        (format stream
+                "READER-ERROR ~@[at ~W ~]~
+                  ~@[(line ~W~]~@[, column ~W) ~]~
+                  on ~S:~%~?"
+                pos lineno colno error-stream
+                (reader-error-format-control condition)
+                (reader-error-format-arguments condition)))))))
 \f
 ;;;; various other (not specified by ANSI) CONDITIONs
 ;;;;
@@ -751,6 +787,7 @@
 (define-condition nil-array-accessed-error (type-error)
   ()
   (:report (lambda (condition stream)
+            (declare (ignore condition))
             (format stream
                     "An attempt to access an array of element-type ~
                       NIL was made.  Congratulations!"))))