diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 1326de04a647b19228c3c8dedb2aa5560825c89e..3196762b3c3fac2e0066e452d885f5b5c3df7062 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.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-int.lisp,v 1.112 2004/08/03 11:59:42 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.113 2004/08/30 14:55:38 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -32,7 +32,7 @@
 
 	  top-frame frame-down frame-up flush-frames-above frame-debug-function
 	  frame-code-location eval-in-frame return-from-frame frame-catches
-	  frame-number frame frame-p
+	  frame-number frame frame-p find-debug-tag-for-frame
 
 	  do-debug-function-blocks debug-function-lambda-list
 	  debug-variable-info-available do-debug-function-variables
@@ -3836,6 +3836,28 @@
   (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
 
 
+;;; FIND-DEBUG-TAG-FOR-FRAME  --  Public.
+;;;
+;;; helper function, used also by debug:debug-return.
+(defun find-debug-tag-for-frame (frame)
+  "Find and return the debug catch tag for a given frame, if it exists."
+  (assoc-if #'(lambda (x)
+		(and (symbolp x)
+		     (not (symbol-package x))
+		     (string= x :cmucl-debug-catch-tag)))
+	    (frame-catches frame)))
+
+
+;;; RETURN-FROM-FRAME  --  Public.
+;;;
+(defun return-from-frame (frame form)
+  (declare (type frame frame))
+  "Evaluate Form in the lexical context of Frame's current code location,
+   returning from the current frame the results of the evaluation."
+  (let ((tag (find-debug-tag-for-frame frame)))
+    (when tag (throw (car tag) (eval-in-frame frame form)))))
+
+
 
 ;;;; Breakpoints.
 
diff --git a/code/debug.lisp b/code/debug.lisp
index 374e2afb84e1d29f454df02463e76a97c1aef095..2d814cc3b97ec53ef6978aeafdd8f3a1381d7016 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.63 2003/08/08 11:36:25 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.64 2004/08/30 14:55:38 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -124,13 +124,10 @@ Breakpoints and steps:
     Abbreviations: BR, BP
   STEP [n]                          step to the next location or step n times.
 
-Function and macro commands:
- (DEBUG:DEBUG-RETURN expression)
+Actions on frames:
+  DEBUG-RETURN expression
     returns expression's values from the current frame, exiting the debugger.
- (DEBUG:ARG n)
-    returns the n'th argument, remaining in the debugger.
- (DEBUG:VAR string-or-symbol [id])
-    returns the specified variable's value, remaining in the debugger.
+    Abbreviations: R
 
 See the CMU Common Lisp User's Manual for more information.
 ")
@@ -1239,6 +1236,21 @@ See the CMU Common Lisp User's Manual for more information.
 
 (def-debug-command-alias "F" "FRAME")
 
+;; debug-return, equivalent to return-from-frame in some other lisps,
+;; allows us to return an arbitrary value from any frame
+(def-debug-command "DEBUG-RETURN" (&optional
+				   (return (read-prompting-maybe
+					    "debug-return: ")))
+  (unless (di:return-from-frame *current-frame* return)
+    ;; the "unless" here is for aesthetical purposes only. If all goes
+    ;; well with return-from-frame, the code after it will never get
+    ;; reached anyway.
+    (format t "~@<can't find a tag for this frame ~
+                   ~2I~_(hint: try increasing the DEBUG optimization quality ~
+                   and recompiling)~:@>")))
+
+(def-debug-command-alias "R" "DEBUG-RETURN")
+
 
 ;;;
 ;;; In and Out commands.
diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp
index fa681cc400eb6d3d41861fe4db0b30d3dde64756..600b9df58424fb5c092459321457116d8feefa32 100644
--- a/compiler/ir1opt.lisp
+++ b/compiler/ir1opt.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/ir1opt.lisp,v 1.82 2003/10/26 17:31:25 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.83 2004/08/30 14:55:38 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1662,7 +1662,12 @@
 		     (fun (ir1-convert-lambda
 			   `(lambda (&optional ,@dums &rest ,ignore)
 			      (declare (ignore ,ignore))
-			      (funcall ,(ref-leaf ref) ,@dums)))))
+			      (funcall ,(ref-leaf ref) ,@dums))
+			   nil		; name
+			   nil		; parent-form
+			   nil		; allow-debug-catch-tag
+			   'ir1-optimize-mv-call ; caller
+			   )))
 		(change-ref-leaf ref fun)
 		(assert (eq (basic-combination-kind node) :full))
 		(local-call-analyze *current-component*)
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index 393f0a64eae36768a01b73c79dc3daf94e08e4bb..630c94c1b265a69e049c61f184a4e6c67ad526ae 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.170 2004/04/28 17:58:08 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.171 2004/08/30 14:55:38 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -141,6 +141,17 @@
            (member (car y) '(flet labels))
            (equal x (cadr y)))))
 
+
+;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
+;;; insertion a (CATCH ...) around code to allow the debugger
+;;; return-from-frame (RETURN) command to work.
+(defvar *allow-debug-catch-tag* t)
+
+;;; This is for debugging the return-from-frame functionality. These are
+;;; supposed to go away in the future. --jwr
+(defvar *print-debug-tag-conversions* nil)
+(defvar *print-debug-tag-converted-bodies* nil)
+
 
 ;;;; Dynamic-Extent
 
@@ -669,6 +680,8 @@
 	  (setq trail (cdr trail)))))))
 
 
+
+
 ;;;; IR1-CONVERT, macroexpansion and special-form dispatching.
 
 (declaim (start-block ir1-convert ir1-convert-progn-body
@@ -722,7 +735,12 @@
 	      (compiler-error "Illegal function call."))
 	     (t
 	      (ir1-convert-combination start cont form
-				       (ir1-convert-lambda fun)))))))))
+				       ;; TODO: check this case --jwr
+				       (ir1-convert-lambda fun 
+							   nil ; name
+							   nil ; parent-form
+							   t
+							   'ir1-convert)))))))))
 
 
 ;;; Reference-Constant  --  Internal
@@ -1476,6 +1494,97 @@
     key))
 
 
+;;; IR1-wrap-for-debug -- Internal
+;;;
+;;; Wrap a piece of code in a catch form, so that we can later throw to it 
+;;; in the debugger, to return a value.
+;;;
+(defun ir1-wrap-for-debug (body)
+  (let ((new-body `((catch (make-symbol "CMUCL-DEBUG-CATCH-TAG")
+		      ,@body))))
+    (when (and *compile-print* 
+	       *print-debug-tag-conversions*
+	       *print-debug-tag-converted-bodies*)
+      (format t "new-body: ~S~%" new-body))
+    new-body))
+
+
+;;; IR1-Convert-Lambda  --  Internal
+;;;
+;;;    Convert a Lambda into a Lambda or Optional-Dispatch leaf.  NAME and
+;;; PARENT-FORM are context that is used to drive the context sensitive
+;;; declaration mechanism.  If we find an entry in *CONTEXT-DECLARATIONS* that
+;;; matches this context (by returning a non-null value) then we add it into
+;;; the local declarations.
+;;;
+(defun ir1-convert-lambda (form &optional
+				name 
+				parent-form
+				allow-debug-catch-tag
+				caller)
+  (unless (consp form)
+    (compiler-error "Found a ~S when expecting a lambda expression:~%  ~S"
+		    (type-of form) form))
+  (unless (eq (car form) 'lambda)
+    (compiler-error "Expecting a lambda, but form begins with ~S:~%  ~S"
+		    (car form) form))
+  (unless (and (consp (cdr form)) (listp (cadr form)))
+    (compiler-error "Lambda-list absent or not a list:~%  ~S" form))
+
+  (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
+      (find-lambda-vars (cadr form))
+    (multiple-value-bind (body decls)
+	(system:parse-body (cddr form) *lexical-environment* t)
+      (let* ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* 
+					   allow-debug-catch-tag))
+	     (new-body (if (and parent-form
+				*allow-debug-catch-tag*
+				(policy nil (= debug 3))) ; TODO: check the policy settings --jwr
+			   (progn
+			     (when (and *compile-print* *print-debug-tag-conversions*)
+			       (format t "ir1-convert-lambda: called by: ~S, parent-form: ~S~%" 
+				       caller parent-form))
+			     (ir1-wrap-for-debug body))
+			   body))
+	     (*current-function-names*
+	      (if (member parent-form
+			  '(flet labels defun defmacro define-compiler-macro)
+			  :test #'eq)
+		  (list name)
+		  *current-function-names*))
+	     (context-decls
+	      (and parent-form
+		   (loop for fun in *context-declarations*
+			 append (funcall (the function fun)
+					 name parent-form))))
+	     (cont (make-continuation))
+	     (*lexical-environment*
+	      (process-declarations (append context-decls decls)
+				    (append aux-vars vars)
+				    nil cont))
+	     (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
+		      (ir1-convert-hairy-lambda new-body vars keyp
+						allow-other-keys
+						aux-vars aux-vals cont)
+		      (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))
+	(setf (leaf-name res)
+	      (or name
+		  ;; PCL-generated lambdas end up here without an explicit NAME.
+		  ;; To avoid ending up with IR1 lambda-nodes that are unnamed,
+		  ;; we extract a name from the "method-name" declaration that
+		  ;; is inserted by PCL. A cleaner solution would be to add a
+		  ;; NAMED-LAMBDA IR1 translator, similar to that used in SBCL,
+		  ;; and make PCL use that instead of LAMBDA.
+		  (let ((decl (find 'pcl::method-name decls :key 'caadr)))
+		    (and decl
+			 (eq 'declare (first decl))
+			 (cons 'pcl::method (cadadr decl))))))
+	res))))
+
+
 ;;; Find-Lambda-Vars  --  Internal
 ;;;
 ;;;    Parse a lambda-list into a list of Var structures, stripping off any aux
@@ -2196,65 +2305,6 @@
     res))
 
     
-;;; IR1-Convert-Lambda  --  Internal
-;;;
-;;;    Convert a Lambda into a Lambda or Optional-Dispatch leaf.  NAME and
-;;; PARENT-FORM are context that is used to drive the context sensitive
-;;; declaration mechanism.  If we find an entry in *CONTEXT-DECLARATIONS* that
-;;; matches this context (by returning a non-null value) then we add it into
-;;; the local declarations.
-;;;
-(defun ir1-convert-lambda (form &optional name parent-form)
-  (unless (consp form)
-    (compiler-error "Found a ~S when expecting a lambda expression:~%  ~S"
-		    (type-of form) form))
-  (unless (eq (car form) 'lambda)
-    (compiler-error "Expecting a lambda, but form begins with ~S:~%  ~S"
-		    (car form) form))
-  (unless (and (consp (cdr form)) (listp (cadr form)))
-    (compiler-error "Lambda-list absent or not a list:~%  ~S" form))
-
-  (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
-      (find-lambda-vars (cadr form))
-    (multiple-value-bind (body decls)
-	(system:parse-body (cddr form) *lexical-environment* t)
-      (let* ((*current-function-names*
-	      (if (member parent-form
-			  '(flet labels defun defmacro define-compiler-macro)
-			  :test #'eq)
-		  (list name)
-		  *current-function-names*))
-	     (context-decls
-	      (and parent-form
-		   (loop for fun in *context-declarations*
-		         append (funcall (the function fun)
-					 name parent-form))))
-	     (cont (make-continuation))
-	     (*lexical-environment*
-	      (process-declarations (append context-decls decls)
-				    (append aux-vars vars)
-				    nil cont))
-	     (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
-		      (ir1-convert-hairy-lambda body vars keyp
-						allow-other-keys
-						aux-vars aux-vals cont)
-		      (ir1-convert-lambda-body body vars aux-vars aux-vals
-					       t cont))))
-        (setf (functional-inline-expansion res) form)
-	(setf (functional-arg-documentation res) (cadr form))
-	(setf (leaf-name res)
-              (or name
-                  ;; PCL-generated lambdas end up here without an explicit NAME.
-                  ;; To avoid ending up with IR1 lambda-nodes that are unnamed,
-                  ;; we extract a name from the "method-name" declaration that
-                  ;; is inserted by PCL. A cleaner solution would be to add a
-                  ;; NAMED-LAMBDA IR1 translator, similar to that used in SBCL,
-                  ;; and make PCL use that instead of LAMBDA.
-                  (let ((decl (find 'pcl::method-name decls :key 'caadr)))
-                    (and decl
-                         (eq 'declare (first decl))
-                         (cons 'pcl::method (cadadr decl))))))
-	res))))
 
 (declaim (end-block))
 
@@ -2695,11 +2745,14 @@
 	     (reference-leaf start cont fn))))
     (if (consp thing)
 	(case (car thing)
-	  ((lambda)
-	   (reference-leaf start cont (ir1-convert-lambda thing nil 'function)))
+	  ((lambda)			
+	   ;; we set allow-debug-catch-tag here, needed for CLOS --jwr
+	   (reference-leaf start cont (ir1-convert-lambda thing nil 'function t)))
 	  ((instance-lambda)
+	   ;; TODO: check if we should allow-debug-catch-tag here --jwr
 	   (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
-					  nil 'function)))
+					  nil ; name
+					  'function)))
 	     (setf (getf (functional-plist res) :fin-function) t)
 	     (reference-leaf start cont res)))
 	  (t
@@ -3132,6 +3185,11 @@
   (multiple-value-bind (names defs)
       (extract-flet-variables definitions 'flet)
     (let* ((fvars (mapcar #'(lambda (n d)
+			      ;; There is no point in allowing debug
+			      ;; catch tag to be inserted here, since in
+			      ;; CMUCL (as opposed to SBCL) flet
+			      ;; function calls do not make it to the
+			      ;; debugger anyway? --jwr
 			      (ir1-convert-lambda d n 'flet))
 			  names defs))
 	   (*lexical-environment*
@@ -3158,6 +3216,9 @@
 	   (real-funs 
 	    (let ((*lexical-environment* (make-lexenv :functions new-fenv)))
 	      (mapcar #'(lambda (n d)
+			  ;; see comments in (def-ir1-translator flet)
+			  ;; on why we don't set allow-debug-catch-tag
+			  ;; to t here --jwr
 			  (ir1-convert-lambda d n 'labels))
 		      names defs))))
 
@@ -3635,7 +3696,9 @@
   (let ((name (eval name))
 	(def (second def))) ; Don't want to make a function just yet...
     (let* ((*current-path* (revert-source-path 'define-compiler-macro))
-	   (fun (ir1-convert-lambda def name 'define-compiler-macro)))
+	   (fun (ir1-convert-lambda def 
+				    name 
+				    'define-compiler-macro)))
       (setf (leaf-name fun) (list :compiler-macro name))
       (setf (functional-arg-documentation fun) (eval lambda-list))
 
@@ -3842,7 +3905,18 @@
     (unless (eq (defined-function-inlinep var) :inline)
       (setf (defined-function-inline-expansion var) nil))
     (let* ((name (leaf-name var))
-	   (fun (funcall converter lambda name parent-form))
+	   ;; converter is either ir1-convert-lambda or ir1-convert-inline-lambda
+	   ;; we allow-debug-catch-tag if it's not inline --jwr
+	   (fun (if (eq converter #'ir1-convert-inline-lambda)
+		    (funcall converter 
+			     lambda 
+			     name 
+			     parent-form)
+		    (funcall converter 
+			     lambda 
+			     name 
+			     parent-form
+			     t)))
 	   (function-info (info function info name)))
       (setf (functional-inlinep fun) (defined-function-inlinep var))
       (assert-new-definition var fun)