X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=08f2f99a562d58dad4649d6f5125c76cffe42b11;hb=b31eab5875e8058a2fdfcb879e23c2724d25a278;hp=fc216f0691a569d08024ddc71627ad2825a40169;hpb=0a8778552a8499dd4614c9aada7dfca3dfcc6997;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index fc216f0..08f2f99 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -264,7 +264,8 @@ (condition-classoid type) (class ;; Punt to CLOS. - (return-from make-condition (apply #'make-instance type args))) + (return-from make-condition + (apply #'make-instance type args))) (classoid (error 'simple-type-error :datum type @@ -275,7 +276,8 @@ (error 'simple-type-error :datum type :expected-type 'condition-class - :format-control "Bad type argument:~% ~S" + :format-control + "~s doesn't designate a condition class." :format-arguments (list type))))) (res (make-condition-object args))) (setf (%instance-layout res) (classoid-layout class)) @@ -398,8 +400,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 +415,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 +553,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 +580,16 @@ ',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) + ',name))))) ;;;; various CONDITIONs specified by ANSI @@ -759,49 +769,44 @@ (:report (lambda (condition stream) (%report-reader-error condition stream :simple t)))) +(defun stream-error-position-info (stream &optional position) + (unless (interactive-stream-p stream) + (let ((now (file-position-or-nil-for-error stream)) + (pos position)) + (when (and (not pos) now (plusp now)) + ;; FILE-POSITION is the next character -- error is at the previous one. + (setf pos (1- now))) + (let (lineno colno) + (when (and pos + (< pos sb!xc:array-dimension-limit) + (file-position stream :start)) + (let ((string + (make-string pos :element-type (stream-element-type stream)))) + (when (= pos (read-sequence string 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) 0))))) + (file-position-or-nil-for-error stream now)) + (remove-if-not #'second + (list (list :line lineno) + (list :column colno) + (list :file-position pos))))))) + ;;; base REPORTing of a READER-ERROR ;;; ;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL ;;; and FORMAT-ARGS slots. -(defun %report-reader-error (condition stream &key simple) - (let* ((error-stream (stream-error-stream condition)) - (pos (file-position-or-nil-for-error 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-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))))))) +(defun %report-reader-error (condition stream &key simple position) + (let ((error-stream (stream-error-stream condition))) + (pprint-logical-block (stream nil) + (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" + (stream-error-position-info error-stream position) + error-stream)))) ;;;; special SBCL extension conditions @@ -1000,8 +1005,9 @@ ((name :initarg :name :reader implicit-generic-function-name)) (:report (lambda (condition stream) - (format stream "~@" - (implicit-generic-function-name condition))))) + (let ((*package* (find-package :keyword))) + (format stream "~@" + (implicit-generic-function-name condition)))))) (define-condition extension-failure (reference-condition simple-error) ()) @@ -1014,22 +1020,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 "~~@" - (package-name (package-error-package condition)) - control) - (package-error-format-arguments condition)) - (format stream "~@" - (package-name (package-error-package condition))))))) + (format nil "~~@" + error-package + control + current-package) + (simple-condition-format-arguments condition)) + (format stream "~@" + error-package + current-package))))) ;; no :default-initargs -- reference-stuff provided by the ;; signalling form in target-package.lisp #!+sb-doc @@ -1084,15 +1094,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 - "~@" - (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 @@ -1209,7 +1210,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition simple-package-error (simple-condition package-error) ()) -(define-condition simple-reader-package-error (simple-reader-error) ()) +(define-condition simple-reader-package-error (simple-reader-error package-error) ()) (define-condition reader-eof-error (end-of-file) ((context :reader reader-eof-error-context :initarg :context)) @@ -1615,7 +1616,7 @@ the usual naming convention (names like *FOO*) for special variables" (define-condition deprecation-condition () ((name :initarg :name :reader deprecated-name) - (replacement :initarg :replacement :reader deprecated-name-replacement) + (replacements :initarg :replacements :reader deprecated-name-replacements) (since :initarg :since :reader deprecated-since) (runtime-error :initarg :runtime-error :reader deprecated-name-runtime-error))) @@ -1623,14 +1624,21 @@ the usual naming convention (names like *FOO*) for special variables" (let ((*package* (find-package :keyword))) (if *print-escape* (print-unreadable-object (condition stream :type t) - (format stream "~S is deprecated~@[, use ~S~]" + (apply #'format + stream "~S is deprecated.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~} instead.~]" (deprecated-name condition) - (deprecated-name-replacement condition))) - (format stream "~@<~S has been deprecated as of SBCL ~A~ - ~@[, use ~S instead~].~:@>" + (deprecated-name-replacements condition))) + (apply #'format + stream "~@<~S has been deprecated as of SBCL ~A.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~:_~} instead.~]~:@>" (deprecated-name condition) (deprecated-since condition) - (deprecated-name-replacement condition))))) + (deprecated-name-replacements condition))))) (define-condition early-deprecation-warning (style-warning deprecation-condition) ()) @@ -1700,11 +1708,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