diff --git a/code/debug.lisp b/code/debug.lisp index f820337167d58ff4d44619de481a3d28e3d46d24..7a9457be54533d02c85e615a5ed5923f1bf07e4d 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 716b63d3a1332b0b35d03495c7d4b16834589da0..9503aa57a85683e91125d8eccd727aa1e2c59d0d 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))