X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=ecd3766482899e7d36971fd99402cf6d3bb75508;hb=50eb070bdefc01733fa6b41427bbe32c7695fd71;hp=7d3f7a7a4bb32f3bea106e1942fc177e7d849496;hpb=d1287b8413141509ca384971f615dde98979583e;p=sbcl.git

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 7d3f7a7..ecd3766 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -233,8 +233,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)
@@ -775,12 +774,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))
@@ -826,7 +821,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))
@@ -940,6 +936,12 @@ symbol that caused the violation is accessed by the function
 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
 
 ) ; progn
+
+(define-condition undefined-alien-error (error) ()
+  (:report
+   (lambda (condition stream)
+     (declare (ignore condition))
+     (format stream "Attempt to access an undefined alien value."))))
 
 ;;;; various other (not specified by ANSI) CONDITIONs
 ;;;;
@@ -1079,6 +1081,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
 
@@ -1120,5 +1180,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")