From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 7 Jan 2003 14:23:24 +0000 (+0000)
Subject: 0.7.11.5:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=650499e7ae935d53cc1e0de6fc73e10dca5be253;p=sbcl.git

0.7.11.5:
	Implement the RETURN debugger command.
	... CATCH block insertion conditional on
		(> DEBUG (MAX SPEED SPACE))
	... change interactor policy to make this the case
	... note as experimental in DEBUG help string
---

diff --git a/CREDITS b/CREDITS
index e15b787..03fa3b4 100644
--- a/CREDITS
+++ b/CREDITS
@@ -551,6 +551,9 @@ Matthias Hoelzl:
 Espen S Johnsen:
   He provided an ANSI-compliant version of CHANGE-CLASS for PCL.
 
+Frederik Kuivinen:
+  He showed how to implement the DEBUG-RETURN functionality.
+
 Arthur Lemmens:
   He found and fixed a number of SBCL bugs while partially porting
   SBCL to bootstrap under Lispworks for Windows
diff --git a/NEWS b/NEWS
index 3cb64d9..a37479d 100644
--- a/NEWS
+++ b/NEWS
@@ -1484,6 +1484,13 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10:
     of the new implementation of DEFINE-COMPILER-MACRO.
 
 changes in sbcl-0.7.12 relative to sbcl-0.7.11:
+  * minor incompatible change: code processed by the "interpreter" or
+    EVAL now has a compilation optimization policy of (DEBUG 2)
+    (changed from (DEBUG 1)) to improve debuggability of interactive
+    development, and to allow the use of the debug RETURN command in
+    such code.
+  * an experimental implementation of the RETURN command for the
+    debugger has been included.  (thanks to Frederik Kuivinen)
   * fixed bug 62: constraints were not propagated into a loop.
   * fixed bug in embedded calls of SORT (reported and investigated by
     Wolfgang Jenkner).
diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 87d5377..3fa6b09 100644
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -122,17 +122,20 @@ Breakpoints and steps:
   STEP [n]                           Step to the next location or step n times.
 
 Function and macro commands:
- (SB-DEBUG:DEBUG-RETURN expression)
-    Exit the debugger, returning expression's values from the current frame.
  (SB-DEBUG:ARG n)
     Return the n'th argument in the current frame.
  (SB-DEBUG:VAR string-or-symbol [id])
     Returns the value of the specified variable in the current frame.
 
 Other commands:
-  SLURP   Discard all pending input on *STANDARD-INPUT*. (This can be
-          useful when the debugger was invoked to handle an error in
-          deeply nested input syntax, and now the reader is confused.)")
+  RETURN expr
+    [EXPERIMENTAL] Return the values resulting from evaluation of expr
+    from the current frame, if this frame was compiled with a sufficiently
+    high DEBUG optimization quality.
+  SLURP
+    Discard all pending input on *STANDARD-INPUT*. (This can be
+    useful when the debugger was invoked to handle an error in
+    deeply nested input syntax, and now the reader is confused.)")
 
 ;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
 (define-condition step-condition (simple-condition) ())
@@ -1670,6 +1673,24 @@ reset to ~S."
 
 (!def-debug-command "SLURP" ()
   (loop while (read-char-no-hang *standard-input*)))
+
+(!def-debug-command "RETURN" (&optional
+			      (return (read-prompting-maybe
+				       "return: ")))
+  (let ((tag (find-if (lambda (x)
+			(and (typep (car x) 'symbol)
+			     (not (symbol-package (car x)))
+			     (string= (car x) "SB-DEBUG-CATCH-TAG")))
+		      (sb!di::frame-catches *current-frame*))))
+    (if tag
+	(throw (car tag)
+	  (funcall (sb!di:preprocess-for-eval
+		    return
+		    (sb!di:frame-code-location *current-frame*))
+		   *current-frame*))
+	(format t "~@<can't find a tag for this frame ~
+                   ~2I~_(hint: try increasing the DEBUG optimization quality ~
+                   and recompiling)~:@>"))))
 
 ;;;; debug loop command utilities
 
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 8eb3b48..d22a012 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -440,7 +440,8 @@
 			 cont
 			 (ir1-convert-lambda thing
 					     :debug-name (debug-namify
-							  "#'~S" thing))))
+							  "#'~S" thing)
+					     :allow-debug-catch-tag t)))
 	((setf)
 	 (let ((var (find-lexically-apparent-fun
 		     thing "as the argument to FUNCTION")))
@@ -448,7 +449,8 @@
 	((instance-lambda)
 	 (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
 					:debug-name (debug-namify "#'~S"
-								  thing))))
+								  thing)
+					:allow-debug-catch-tag t)))
 	   (setf (getf (functional-plist res) :fin-function) t)
 	   (reference-leaf start cont res)))
 	(t
@@ -482,9 +484,11 @@
 (def-ir1-translator named-lambda ((name &rest rest) start cont)
   (let* ((fun (if (legal-fun-name-p name)
                   (ir1-convert-lambda `(lambda ,@rest)
-                                      :source-name name)
+                                      :source-name name
+				      :allow-debug-catch-tag t)
                   (ir1-convert-lambda `(lambda ,@rest)
-                                      :debug-name name)))
+                                      :debug-name name
+				      :allow-debug-catch-tag t)))
          (leaf (reference-leaf start cont fun)))
     (when (legal-fun-name-p name)
       (assert-global-function-definition-type name fun))
@@ -657,7 +661,8 @@
   			      (ir1-convert-lambda d
 						  :source-name n
 						  :debug-name (debug-namify
-							       "FLET ~S" n)))
+							       "FLET ~S" n)
+						  :allow-debug-catch-tag t))
 			    names defs))
 	     (*lexenv* (make-lexenv
 			:default (process-decls decls nil fvars cont)
@@ -692,7 +697,8 @@
 			  (ir1-convert-lambda def
 					      :source-name name
 					      :debug-name (debug-namify
-							   "LABELS ~S" name)))
+							   "LABELS ~S" name)
+					      :allow-debug-catch-tag t))
 			names defs))))
 
         ;; Modify all the references to the dummy function leaves so
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 776d279..aa346d4 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -501,7 +501,8 @@
 					       opname
 					       :debug-name (debug-namify
 							    "LAMBDA CAR ~S"
-							    opname)))))))))
+							    opname)
+					       :allow-debug-catch-tag t))))))))
     (values))
 
   ;; Generate a reference to a manifest constant, creating a new leaf
@@ -1941,7 +1942,9 @@
     res))
 
 ;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
-(defun ir1-convert-lambda (form &key (source-name '.anonymous.) debug-name)
+(defun ir1-convert-lambda (form &key (source-name '.anonymous.)
+			             debug-name
+			             allow-debug-catch-tag)
 
   (unless (consp form)
     (compiler-error "A ~S was found when expecting a lambda expression:~%  ~S"
@@ -1964,6 +1967,11 @@
 	     (*lexenv* (process-decls decls
 				      (append aux-vars vars)
 				      nil result-cont))
+	     (forms (if (and allow-debug-catch-tag
+			     (policy *lexenv* (> debug (max speed space))))
+			`((catch (make-symbol "SB-DEBUG-CATCH-TAG")
+			    ,@forms))
+			forms))
 	     (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
 		      (ir1-convert-hairy-lambda forms vars keyp
 						allow-other-keys
diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp
index 9a94062..acdf1a3 100644
--- a/src/compiler/lexenv.lisp
+++ b/src/compiler/lexenv.lisp
@@ -21,9 +21,9 @@
 	     (:constructor make-null-interactive-lexenv
 			   (&aux (policy (list '(safety . 3)
 					       '(compilation-speed . 2)
+					       '(debug . 2)
 					       '(speed . 1)
 					       '(space . 1)
-					       '(debug . 1)
 					       '(inhibit-warnings . 1)))))
 	     (:constructor internal-make-lexenv
 			   (funs vars blocks tags
diff --git a/version.lisp-expr b/version.lisp-expr
index 0b5bc62..033a033 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.11.4"
+"0.7.11.5"