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