X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=b89d6d80270143dd9f073261d46a74b25cdeb693;hb=568214ddf4c8ecc881caec98e20848d017974ec0;hp=65e969786f1eec2b1462c214e844177b3add6158;hpb=c2fd998cbeea4a2049e8b77bf36c6e478ebb7d44;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 65e9697..b89d6d8 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -13,6 +13,26 @@ (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 &optional (pos nil posp)) + ;; 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.) + (if posp + (ignore-errors (file-position stream pos)) + (ignore-errors (file-position stream)))) + ;;;; the CONDITION class (/show0 "condition.lisp 20") @@ -233,8 +253,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) @@ -296,7 +315,8 @@ "new" (layout-length layout) (layout-inherits layout) - (layout-depthoid layout)) + (layout-depthoid layout) + (layout-n-untagged-slots layout)) (register-layout layout :invalidate t)) ((not (classoid-layout class)) (register-layout layout))) @@ -628,6 +648,12 @@ (define-condition cell-error (error) ((name :reader cell-error-name :initarg :name))) +(def!method print-object ((condition cell-error) stream) + (if *print-escape* + (print-unreadable-object (condition stream :type t :identity t) + (princ (cell-error-name condition) stream)) + (call-next-method))) + (define-condition unbound-variable (cell-error) () (:report (lambda (condition stream) @@ -690,7 +716,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) @@ -708,13 +734,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) ~]~ @@ -755,6 +782,8 @@ .~:@>" '((fmakunbound 'compile)))))) +(define-condition simple-storage-condition (storage-condition simple-condition) ()) + ;;; a condition for use in stubs for operations which aren't supported ;;; on some platforms ;;; @@ -775,12 +804,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)) @@ -792,6 +817,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 ", ") @@ -809,8 +841,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))) @@ -818,7 +851,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)) @@ -890,6 +924,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 @@ -932,6 +971,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 ;;;; @@ -939,16 +993,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))) -;;; This comes to play if we have multiple levels of encapsulated -;;; errors and we need to dump them with MAKE-CONDITION-LOAD-FORM. -;;; Should not see much/any use, but better to have it. -(def!method make-load-form ((condition encapsulated-condition) &optional env) - `(make-condition 'encapsulated-condition - :condition ,(make-condition-load-form (encapsulated-condition condition) env))) - (define-condition values-type-error (type-error) () (:report @@ -1071,12 +1119,77 @@ 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) ()) + +(define-condition declaration-type-conflict-error (reference-condition + simple-error) + () + (:default-initargs + :format-control "symbol ~S cannot be both the name of a type and the name of a declaration" + :references (list '(:ansi-cl :section (3 8 21))))) + +;;; 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 @@ -1118,5 +1231,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")