;;; 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
(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))
(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
#!+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
(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