From 9bf565fe200b5efd54af642fd19fb373157c67e1 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Mon, 14 Apr 2003 21:15:03 +0000
Subject: [PATCH] Allow the debugger to return a value from a function.  Based
 on work posted to cmucl-imp by Fredrik Kuivinen and the implementation in
 SBCL.  A catch tag is wrapped around the function to which the debugger can
 throw to to return a new value.

This is enabled only if debug is more important than both speed
and space.
---
 code/debug.lisp       | 18 +++++++++++++++++-
 compiler/ir1tran.lisp | 18 +++++++++++++++---
 2 files changed, 32 insertions(+), 4 deletions(-)

diff --git a/code/debug.lisp b/code/debug.lisp
index f82033716..7a9457be5 100644
--- a/code/debug.lisp
+++ b/code/debug.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.56 2003/01/16 20:53:01 cracauer Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.57 2003/04/14 21:15:03 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1709,6 +1709,22 @@ See the CMU Common Lisp User's Manual for more information.
 	(describe function)
 	(format t "Can't figure out the function for this frame."))))
 
+(def-debug-command "RETURN" ()
+  (let ((tag (find-if #'(lambda (x)
+			  (and (typep (car x) 'symbol)
+			       (not (symbol-package (car x)))
+			       (string= (car x) "DEBUG-RETURN-CATCH-TAG")))
+		      (di::frame-catches debug::*current-frame*))))
+    (if tag
+	(throw (car tag)
+	  (di::eval-in-frame debug::*current-frame*
+			     (debug::read-if-available '(values))))
+	(format t "~@<can't find the return tag for this frame ~
+                   ~2I~_(hint: try increasing the DEBUG optimization quality ~
+                   and recompiling)~:@>"))))
+
+
+
 
 ;;;
 ;;; Editor commands.
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index 716b63d3a..9503aa57a 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.143 2003/04/11 14:24:21 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.144 2003/04/14 21:15:03 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1987,6 +1987,10 @@
       
     res))
 
+(defvar *allow-debug-catch-tag* t
+  "Controls whether we should allow the insertion a (CATCH ...) around
+code to allow the debugger RETURN command to function.")
+
     
 ;;; IR1-Convert-Lambda  --  Internal
 ;;;
@@ -2016,6 +2020,7 @@
 			  :test #'eq)
 		  (list name)
 		  *current-function-names*))
+	     
 	     (context-decls
 	      (and parent-form
 		   (loop for fun in *context-declarations*
@@ -2026,11 +2031,18 @@
 	      (process-declarations (append context-decls decls)
 				    (append aux-vars vars)
 				    nil cont))
+	     (new-body (cond ((and *allow-debug-catch-tag*
+				   (member parent-form '(defun flet labels function))
+				   (policy nil (> debug (max speed space))))
+			      ;; (format t "body: ~S~%" body)
+                              `((catch (make-symbol "DEBUG-RETURN-CATCH-TAG")
+                                  ,@body)))
+                             (t body)))
 	     (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
-		      (ir1-convert-hairy-lambda body vars keyp
+		      (ir1-convert-hairy-lambda new-body vars keyp
 						allow-other-keys
 						aux-vars aux-vals cont)
-		      (ir1-convert-lambda-body body vars aux-vars aux-vals
+		      (ir1-convert-lambda-body new-body vars aux-vars aux-vals
 					       t cont))))
 	(setf (functional-inline-expansion res) form)
 	(setf (functional-arg-documentation res) (cadr form))
-- 
GitLab