X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=e281b2ac9e1df704d4453a40a0b41bd64f20682b;hb=ca267caa3bdb897a93a1e69ae7300ba3ba5d391f;hp=6b971ecf91515b932845d9170c0eb8e5b36ef85b;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 6b971ec..e281b2a 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -13,6 +13,24 @@ (in-package "SB!KERNEL") +;;;; miscellaneous support utilities + +;;; Signalling an error when trying to print an error condition is +;;; generally a PITA, so whatever the failure encountered when +;;; wondering about FILE-POSITION within a condition printer, 'tis +;;; better silently to give up than to try to complain. +(defun file-position-or-nil-for-error (stream) + ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but + ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem + ;; absolutely unambiguously to prohibit errors when, e.g., STREAM + ;; has been closed so that FILE-POSITION is a nonsense question. So + ;; my (WHN) impression is that the conservative approach is to + ;; IGNORE-ERRORS. (I encountered this failure from within a homebrew + ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd, + ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the + ;; time an error was reported.) + (ignore-errors (file-position stream))) + ;;;; the CONDITION class (/show0 "condition.lisp 20") @@ -233,8 +251,7 @@ "Make an instance of a condition object using the specified initargs." ;; Note: ANSI specifies no exceptional situations in this function. ;; signalling simple-type-error would not be wrong. - (let* ((thing (if (symbolp thing) - (find-classoid thing) + (let* ((thing (or (and (symbolp thing) (find-classoid thing nil)) thing)) (class (typecase thing (condition-classoid thing) @@ -266,7 +283,6 @@ (return nil))) (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) (find-slot-default class hslot)))) - res)) ;;;; DEFINE-CONDITION @@ -691,7 +707,7 @@ (:report (lambda (condition stream) (let* ((error-stream (stream-error-stream condition)) - (pos (file-position error-stream))) + (pos (file-position-or-nil-for-error error-stream))) (let (lineno colno) (when (and pos (< pos sb!xc:array-dimension-limit) @@ -709,13 +725,14 @@ (file-position error-stream :start)) (let ((string (make-string pos - :element-type (stream-element-type error-stream)))) + :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 error-stream pos)) + (file-position-or-nil-for-error error-stream pos)) (format stream "READER-ERROR ~@[at ~W ~]~ ~@[(line ~W~]~@[, column ~W) ~]~ @@ -776,12 +793,8 @@ ;;; 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 (cell-error) () - (:report - (lambda (condition stream) - (format stream - "unsupported on this platform (OS, CPU, whatever): ~S" - (cell-error-name condition))))) +(define-condition unsupported-operator (simple-error) ()) + ;;; (:ansi-cl :function remove) ;;; (:ansi-cl :section (a b c)) @@ -793,6 +806,13 @@ ;;; FIXME: this is not the right place for this. (defun print-reference (reference stream) (ecase (car reference) + (:amop + (format stream "AMOP") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:generic-function (format stream "Generic Function ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data))))) (:ansi-cl (format stream "The ANSI Standard") (format stream ", ") @@ -810,8 +830,9 @@ (destructuring-bind (type data) (cdr reference) (ecase type (:node (format stream "Node ~S" data)) - (:variable (format stream "Variable ~S" data))))) - ;; FIXME: other documents (e.g. AMOP, Franz documentation :-) + (:variable (format stream "Variable ~S" data)) + (:function (format stream "Function ~S" data))))) + ;; FIXME: other documents (e.g. CLIM, Franz documentation :-) )) (define-condition reference-condition () ((references :initarg :references :reader reference-condition-references))) @@ -819,7 +840,8 @@ (def!method print-object :around ((o reference-condition) s) (call-next-method) (unless (or *print-escape* *print-readably*) - (when *print-condition-references* + (when (and *print-condition-references* + (reference-condition-references o)) (format s "~&See also:~%") (pprint-logical-block (s nil :per-line-prefix " ") (do* ((rs (reference-condition-references o) (cdr rs)) @@ -828,7 +850,7 @@ (print-reference r s) (unless (null (cdr rs)) (terpri s))))))) - + (define-condition duplicate-definition (reference-condition warning) ((name :initarg :name :reader duplicate-definition-name)) (:report (lambda (c s) @@ -891,6 +913,11 @@ (define-condition extension-failure (reference-condition simple-error) ()) +(define-condition structure-initarg-not-keyword + (reference-condition simple-style-warning) + () + (:default-initargs :references (list '(:ansi-cl :section (2 4 8 13))))) + #!+sb-package-locks (progn @@ -901,15 +928,15 @@ :reader package-error-format-arguments)) (:report (lambda (condition stream) - (let ((control (package-error-format-control condition)) - (*print-pretty* nil)) + (let ((control (package-error-format-control condition))) (if control - (format stream "Package lock on ~S violated when ~?." - (package-error-package condition) - control - (package-error-format-arguments condition)) - (format stream "Package lock on ~S violated." - (package-error-package condition)))))) + (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))))))) ;; no :default-initargs -- reference-stuff provided by the ;; signalling form in target-package.lisp #!+sb-doc @@ -923,7 +950,6 @@ when a package-lock is violated.")) "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is signalled when an operation on a package violates a package lock.")) - (define-condition symbol-package-locked-error (package-lock-violation) ((symbol :initarg :symbol :reader package-locked-error-symbol)) #!+sb-doc @@ -934,6 +960,21 @@ symbol that caused the violation is accessed by the function SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) ) ; progn + +(define-condition undefined-alien-error (error) ()) + +(define-condition undefined-alien-variable-error (undefined-alien-error) () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Attempt to access an undefined alien variable.")))) + +(define-condition undefined-alien-function-error (undefined-alien-error) () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Attempt to call an undefined alien function.")))) + ;;;; various other (not specified by ANSI) CONDITIONs ;;;; @@ -941,6 +982,10 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) ;;;; setup of CONDITION machinery, only because that makes it easier to ;;;; get cold init to work. +;;; OAOOM warning: see cross-condition.lisp +(define-condition encapsulated-condition (condition) + ((condition :initarg :condition :reader encapsulated-condition))) + (define-condition values-type-error (type-error) () (:report @@ -1063,12 +1108,70 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (lambda (condition stream) (let ((error-stream (stream-error-stream condition))) (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" - (file-position error-stream) error-stream + (file-position-or-nil-for-error error-stream) error-stream (reader-error-format-control condition) (reader-error-format-arguments condition) (reader-impossible-number-error-error condition)))))) (define-condition timeout (serious-condition) ()) + +;;; Single stepping conditions + +(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 +stepped.")) + +#!+sb-doc +(setf (fdocumentation 'step-condition-form 'function) + "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)) + #!+sb-doc + (:documentation "Condition signalled by code compiled with +single-stepping information when about to execute a form. +STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the +pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH +holds the source-path to the original form within that file or NIL. +Associated with this condition are always the restarts STEP-INTO, +STEP-NEXT, and STEP-CONTINUE.")) + +#!+sb-doc +(setf (fdocumentation 'step-condition-source-path 'function) + "Source-path of the original form associated with the +STEP-FORM-CONDITION or NIL." + (fdocumentation 'step-condition-pathname 'function) + "Pathname of the original source-file associated with the +STEP-FORM-CONDITION or NIL.") + +(define-condition step-result-condition (step-condition) + ((result :initarg :result :reader step-condition-result))) + +#!+sb-doc +(setf (fdocumentation 'step-condition-result 'function) + "Return values associated with STEP-VALUES-CONDITION as a list, +or the variable value associated with STEP-VARIABLE-CONDITION.") + +(define-condition step-values-condition (step-result-condition) + () + #!+sb-doc + (:documentation "Condition signalled by code compiled with +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) + () + #!+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.")) + ;;;; restart definitions @@ -1110,5 +1213,26 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if none exists.")) +;;; single-stepping restarts + +(macrolet ((def (name doc) + #!-sb-doc (declare (ignore doc)) + `(defun ,name (condition) + #!+sb-doc ,doc + (invoke-restart (find-restart-or-control-error ',name condition))))) + (def step-continue + "Transfers control to the STEP-CONTINUE restart associated with +the condition, continuing execution without stepping. Signals a +CONTROL-ERROR if the restart does not exist.") + (def step-next + "Transfers control to the STEP-NEXT restart associated with the +condition, executing the current form without stepping and continuing +stepping with the next form. Signals CONTROL-ERROR is the restart does +not exists.") + (def step-into + "Transfers control to the STEP-INTO restart associated with the +condition, stepping into the current form. Signals a CONTROL-ERROR is +the restart does not exist.")) + (/show0 "condition.lisp end of file")