X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=c17e2c3e5d91a6f7e6a845f562b01bca3577baf9;hb=8643c93d4db277f6e1cb880a42407ff29e19f618;hp=165fa06c7c5a8288138d01d8a4db47764ff5630f;hpb=ef793f0d484ac3a527e945a62c93f904d73049a6;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 165fa06..c17e2c3 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 @@ -391,6 +391,8 @@ (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 source-location) @@ -440,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) @@ -524,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) @@ -548,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 @@ -750,13 +755,14 @@ (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))))))) + (pprint-logical-block (stream nil) + (format stream + "READER-ERROR ~@[at ~W ~]~ + ~@[(line ~W~]~@[, column ~W) ~]~ + on ~S:~2I~_~?" + pos lineno colno error-stream + (reader-error-format-control condition) + (reader-error-format-arguments condition)))))))) ;;;; special SBCL extension conditions @@ -806,7 +812,7 @@ ;;; 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 @@ -830,9 +836,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" data)) + (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") @@ -1100,16 +1110,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) @@ -1148,7 +1148,26 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (reader-error-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) @@ -1161,6 +1180,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 @@ -1171,8 +1191,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. @@ -1206,13 +1236,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