X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=6e04cdacb3605d5931e14aa805f7801236a77886;hb=42702bd5e2af3e0042c9f27372c6f5d92335df12;hp=e704d5e29edd7fd1712df9596df5ff07896d5e54;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index e704d5e..6e04cda 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -41,7 +41,7 @@ (/show0 "condition.lisp 24") -(def!struct (condition-classoid (:include slot-classoid) +(def!struct (condition-classoid (:include classoid) (:constructor make-condition-classoid)) ;; list of CONDITION-SLOT structures for the direct slots of this ;; class @@ -69,7 +69,7 @@ (!defstruct-with-alternate-metaclass condition :slot-names (actual-initargs assigned-slots) :boa-constructor %make-condition-object - :superclass-name instance + :superclass-name t :metaclass-name condition-classoid :metaclass-constructor make-condition-classoid :dd-type structure) @@ -391,11 +391,17 @@ (lambda (new-value condition) (condition-writer-function condition new-value slot-name)))) +(defvar *define-condition-hooks* nil) + (defun %define-condition (name parent-types layout slots documentation - report default-initargs all-readers all-writers) + report default-initargs all-readers all-writers + source-location) (with-single-package-locked-error (:symbol name "defining ~A as a condition") (%compiler-define-condition name parent-types layout all-readers all-writers) + (sb!c:with-source-location (source-location) + (setf (layout-source-location layout) + source-location)) (let ((class (find-classoid name))) (setf (condition-classoid-slots class) slots) (setf (condition-classoid-report class) report) @@ -436,7 +442,10 @@ (dolist (initarg (condition-slot-initargs slot) nil) (when (functionp (getf e-def-initargs initarg)) (return t)))) - (push slot (condition-classoid-hairy-slots class)))))))) + (push slot (condition-classoid-hairy-slots class))))))) + (when (boundp '*define-condition-hooks*) + (dolist (fun *define-condition-hooks*) + (funcall fun class)))) name)) (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) @@ -520,8 +529,8 @@ :initform-p ',initform-p :documentation ',documentation :initform - ,(if (constantp initform) - `',(eval initform) + ,(if (sb!xc:constantp initform) + `',(constant-form-value initform) `#'(lambda () ,initform))))))) (dolist (option options) @@ -544,8 +553,8 @@ (let ((val (second initargs))) (setq default-initargs (list* `',(first initargs) - (if (constantp val) - `',(eval val) + (if (sb!xc:constantp val) + `',(constant-form-value val) `#'(lambda () ,val)) default-initargs))))) (t @@ -564,7 +573,8 @@ ,report (list ,@default-initargs) ',(all-readers) - ',(all-writers))))))) + ',(all-writers) + (sb!c:source-location))))))) ;;;; DESCRIBE on CONDITIONs @@ -708,50 +718,71 @@ (*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~_") + (format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))))))) ;;;; special SBCL extension conditions @@ -801,14 +832,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)) @@ -825,7 +855,13 @@ (format stream ", ") (destructuring-bind (type data) (cdr reference) (ecase type + (:readers "Readers for ~:(~A~) Metaobjects" + (substitute #\ #\- (symbol-name data))) + (:initialization + (format stream "Initialization of ~:(~A~) Metaobjects" + (substitute #\ #\- (symbol-name data)))) (:generic-function (format stream "Generic Function ~S" data)) + (:function (format stream "Function ~S" data)) (:section (format stream "Section ~{~D~^.~}" data))))) (:ansi-cl (format stream "The ANSI Standard") @@ -873,6 +909,15 @@ (duplicate-definition-name c)))) (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) +(define-condition constant-modified (reference-condition warning) + ((fun-name :initarg :fun-name :reader constant-modified-fun-name)) + (:report (lambda (c s) + (format s "~@" + (constant-modified-fun-name c)))) + (:default-initargs :references (list '(:ansi-cl :special-operator quote) + '(:ansi-cl :section (3 2 2 3))))) + (define-condition package-at-variance (reference-condition simple-warning) () (:default-initargs :references (list '(:ansi-cl :macro defpackage)))) @@ -1084,16 +1129,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) @@ -1110,7 +1145,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)) @@ -1121,18 +1156,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) @@ -1145,6 +1200,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition step-condition () ((form :initarg :form :reader step-condition-form)) + #!+sb-doc (:documentation "Common base class of single-stepping conditions. STEP-CONDITION-FORM holds a string representation of the form being @@ -1155,8 +1211,18 @@ stepped.")) "Form associated with the STEP-CONDITION.") (define-condition step-form-condition (step-condition) - ((source-path :initarg :source-path :reader step-condition-source-path) - (pathname :initarg :pathname :reader step-condition-pathname)) + ((args :initarg :args :reader step-condition-args)) + (:report + (lambda (condition stream) + (let ((*print-circle* t) + (*print-pretty* t) + (*print-readably* nil)) + (format stream + "Evaluating call:~%~< ~@;~A~:>~%~ + ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%" + (list (step-condition-form condition)) + (eq (step-condition-args condition) :unknown) + (step-condition-args condition))))) #!+sb-doc (:documentation "Condition signalled by code compiled with single-stepping information when about to execute a form. @@ -1190,13 +1256,14 @@ 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-variable-condition (step-result-condition) +(define-condition step-finished-condition (step-condition) () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Returning from STEP"))) #!+sb-doc - (:documentation "Condition signalled by code compiled with -single-stepping information when referencing a variable. -STEP-CONDITION-FORM hold the symbol, and STEP-CONDITION-RESULT holds -the value of the variable. No associated restarts.")) + (:documentation "Condition signaled when STEP returns.")) ;;;; restart definitions