X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=44270bb6851f2e11eefa23aaa78757af87550e42;hb=e87722978bc9993cc5a862964366ee7cd0b7fb4c;hp=c59ccb44b5d2bcc743e980430f80a87c76131b72;hpb=b66385e2031fc2cac17dd129df0af400beb48a22;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index c59ccb4..44270bb 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -718,50 +718,70 @@ (*print-array* nil)) (format stream "~S cannot be printed readably." obj))))) -(define-condition reader-error (parse-error stream-error) - ((format-control - :reader reader-error-format-control - :initarg :format-control) - (format-arguments - :reader reader-error-format-arguments - :initarg :format-arguments - :initform '())) - (:report - (lambda (condition stream) - (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)) - (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))))))) +(define-condition reader-error (parse-error stream-error) () + (:report (lambda (condition stream) + (%report-reader-error condition stream)))) + +;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and +;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from +;;; within SBCL itself) +;;; +;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with +;;; the letter of the ANSI spec: this is not a condition signalled by +;;; SIGNAL when a format-control is supplied by the function's first +;;; argument. It seems to me (WHN) to be basically in the spirit of +;;; the spec, but if not, it'd be straightforward to do our own +;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with +;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in +;;; place of CL:SIMPLE-CONDITION here.) +(define-condition simple-reader-error (reader-error simple-condition) + () + (:report (lambda (condition stream) + (%report-reader-error condition stream :simple t)))) + +;;; 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))))))) ;;;; special SBCL extension conditions @@ -811,14 +831,13 @@ ;;; unimplemented and (2) unintentionally just screwed up somehow. ;;; (Before this condition was defined, test code tried to deal with ;;; this by checking for FBOUNDP, but that didn't work reliably. In -;;; sbcl-0.7.0, a a package screwup left the definition of +;;; sbcl-0.7.0, a package screwup left the definition of ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on ;;; architectures where it was supposed to be supported, and the ;;; regression tests cheerfully passed because they assumed that ;;; unFBOUNDPness meant they were running on an system which didn't ;;; support the extension.) (define-condition unsupported-operator (simple-error) ()) - ;;; (:ansi-cl :function remove) ;;; (:ansi-cl :section (a b c)) @@ -1109,16 +1128,6 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) '(:ansi-cl :section (15 1 2 1)) '(:ansi-cl :section (15 1 2 2))))) -(define-condition io-timeout (stream-error) - ((direction :reader io-timeout-direction :initarg :direction)) - (:report - (lambda (condition stream) - (declare (type stream stream)) - (format stream - "I/O timeout ~(~A~)ing ~S" - (io-timeout-direction condition) - (stream-error-stream condition))))) - (define-condition namestring-parse-error (parse-error) ((complaint :reader namestring-parse-error-complaint :initarg :complaint) (args :reader namestring-parse-error-args :initarg :args :initform nil) @@ -1135,7 +1144,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition simple-package-error (simple-condition package-error) ()) -(define-condition reader-package-error (reader-error) ()) +(define-condition simple-reader-package-error (simple-reader-error) ()) (define-condition reader-eof-error (end-of-file) ((context :reader reader-eof-error-context :initarg :context)) @@ -1146,18 +1155,38 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (stream-error-stream condition) (reader-eof-error-context condition))))) -(define-condition reader-impossible-number-error (reader-error) +(define-condition reader-impossible-number-error (simple-reader-error) ((error :reader reader-impossible-number-error-error :initarg :error)) (:report (lambda (condition stream) (let ((error-stream (stream-error-stream condition))) - (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" + (format stream + "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" (file-position-or-nil-for-error error-stream) error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) (reader-impossible-number-error-error condition)))))) -(define-condition timeout (serious-condition) ()) +(define-condition timeout (serious-condition) + ((seconds :initarg :seconds :initform nil :reader timeout-seconds)) + (:report (lambda (condition stream) + (format stream "Timeout occurred~@[ after ~A seconds~]." + (timeout-seconds condition))))) + +(define-condition io-timeout (stream-error timeout) + ((direction :reader io-timeout-direction :initarg :direction)) + (:report + (lambda (condition stream) + (declare (type stream stream)) + (format stream + "I/O timeout ~(~A~)ing ~S." + (io-timeout-direction condition) + (stream-error-stream condition))))) + +(define-condition deadline-timeout (timeout) () + (:report (lambda (condition stream) + (format stream "A deadline was reached after ~A seconds." + (timeout-seconds condition))))) (define-condition declaration-type-conflict-error (reference-condition simple-error) @@ -1226,6 +1255,15 @@ single-stepping information after executing a form. STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds the values returned by the form as a list. No associated restarts.")) +(define-condition step-finished-condition (step-condition) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Returning from STEP"))) + #!+sb-doc + (:documentation "Condition signaled when STEP returns.")) + ;;;; restart definitions