X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=618db154ef352c7663adf64b302542657ac833c6;hb=1f0efb731e8427080690f8ecaf9a56fc287a9d88;hp=6b971ecf91515b932845d9170c0eb8e5b36ef85b;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 6b971ec..618db15 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -266,7 +266,6 @@ (return nil))) (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) (find-slot-default class hslot)))) - res)) ;;;; DEFINE-CONDITION @@ -776,12 +775,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 +788,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 +812,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 +822,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 +832,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) @@ -901,15 +905,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 +927,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 @@ -941,6 +944,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 @@ -1069,6 +1076,64 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (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 +1175,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")