(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")
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)
(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))
',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
(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)
: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
(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