X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Fcondition.lisp;h=29c854a2b3f380e728a003895527157a5db0bf50;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=f4621466c2fe6f97ccafacd4be03f97c2e016c8e;hpb=fea8ea02847ddc0864546a02480fb3e97d6fa318;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index f462146..29c854a 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))) @@ -557,25 +577,6 @@ (condition-actual-initargs condition) (condition-assigned-slots condition)))) -;;;; MAKE-LOAD-FORM equivalent for conditions. - -;;; We need this to be able to dump arbitrary encapsulated conditions -;;; with MAKE-LOAD-FORM for COMPILED-PROGRAM-ERRORs. Unfortunately -;;; ANSI specifies that MAKE-LOAD-FORM for conditions should signal an -;;; error, despite the fact that it also specifies that the -;;; file-compiler should use MAKE-LOAD-FORM for conditions. Bah. -;;; Badness results if this is called before PCL is in place. Unlike -;;; real make-load-form we return just a single form, so that it can -;;; easily be embedded in the surrounding condition. -(defun make-condition-load-form (condition &optional env) - (with-unique-names (instance) - (multiple-value-bind (create init) - (make-load-form-saving-slots condition :environment env) - (let ((fixed-init (subst instance condition init))) - `(let ((,instance ,create)) - ,fixed-init - ,instance))))) - ;;;; various CONDITIONs specified by ANSI (define-condition serious-condition (condition) ()) @@ -709,7 +710,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) @@ -727,13 +728,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) ~]~ @@ -774,6 +776,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 ;;; @@ -794,12 +798,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)) @@ -811,6 +811,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 ", ") @@ -828,8 +835,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))) @@ -837,7 +845,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)) @@ -909,6 +918,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 @@ -951,6 +965,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 ;;;; @@ -958,16 +987,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 @@ -1090,12 +1113,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 @@ -1137,5 +1225,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")