recursive repl support

* module/system/repl/common.scm (*repl-level*): New public fluid.
  (repl-prompt): If *repl-level* is a positive integer, add it to the
  prompt.

* module/system/repl/repl.scm (start-repl): The `lang' argument is now
  optional, and defaults to (current-language). New kwargs level and
  welcome; level defaults to 0, or 1+ the existing level, and the
  welcome is a boolean, true if level is 0. Parameterize *repl-level*
  during the dynamic extent of this repl. Also, parameterize
  the-last-stack to #f for the duration of this repl.

* module/system/vm/debug.scm (frame->module, debugger-repl): Stubs of a
  recursive repl implementation. The idea is to be a repl in the lexical
  context of the error; but it would be nice to be able to operate in
  the module of the proc too, for example to export bindings. Hmm.

3 files changed, 65 insertions, 38 deletions

diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index a106145a2..6901d320b 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -29,7 +29,8 @@
             repl-welcome repl-prompt repl-read repl-compile repl-eval
             repl-parse repl-print repl-option-ref repl-option-set!
             puts ->string user-error
-            *warranty* *copying* *version*))
+            *warranty* *copying* *version*
+            *repl-level*))
 
 (define *version*
   (format #f "GNU Guile ~A
@@ -93,6 +94,8 @@ copy of the Program in return for a fee.
 
 See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
 
+(define *repl-level* (make-fluid))
+
 
 ;;;
 ;;; Repl type
@@ -118,8 +121,10 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
   (display "Enter `,help' for help.\n"))
 
 (define (repl-prompt repl)
-  (format #f "~A@~A> " (language-name (repl-language repl))
-          (module-name (current-module))))
+  (format #f "~A@~A~A> " (language-name (repl-language repl))
+          (module-name (current-module))
+          (let ((level (or (fluid-ref *repl-level*) 0)))
+            (if (zero? level) "" (format #f " [~a]" level)))))
 
 (define (repl-read repl)
   ((language-reader (repl-language repl)) (current-input-port)
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 8c54345ca..92f262c37 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -1,6 +1,6 @@
 ;;; Read-Eval-Print Loop
 
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -92,42 +92,47 @@
 (define-macro (with-backtrace form)
   `(call-with-backtrace (lambda () ,form)))
 
-(define (start-repl lang)
+(define* (start-repl #:optional (lang (current-language)) #:key
+                     (level (1+ (or (fluid-ref *repl-level*) -1)))
+                     (welcome (equal? level 0)))
   (let ((repl (make-repl lang))
         (status #f))
-    (repl-welcome repl)
-    (let prompt-loop ()
-      (let ((exp (with-backtrace (prompting-meta-read repl))))
-        (cond
-         ((eqv? exp (if #f #f))) ; read error, pass
-         ((eq? exp meta-command-token)
-          (with-backtrace (meta-command repl)))
-         ((eof-object? exp)
-          (newline)
-          (set! status '()))
-         (else
-          ;; since the input port is line-buffered, consume up to the
-          ;; newline
-          (flush-to-newline)
-          (with-backtrace
-           (catch 'quit
-                  (lambda ()
-                    (call-with-values
-                        (lambda ()
-                          (run-hook before-eval-hook exp)
-                          (start-stack #t
-                                       (repl-eval repl (repl-parse repl exp))))
-                      (lambda l
-                        (for-each (lambda (v)
-                                    (run-hook before-print-hook v)
-                                    (repl-print repl v))
-                                  l))))
-                  (lambda (k . args)
-                    (set! status args))))))
-        (or status
-            (begin
-              (next-char #f) ;; consume trailing whitespace
-              (prompt-loop)))))))
+    (if welcome
+        (repl-welcome repl))
+    (with-fluids ((*repl-level* level)
+                  (the-last-stack #f))
+      (let prompt-loop ()
+        (let ((exp (with-backtrace (prompting-meta-read repl))))
+          (cond
+           ((eqv? exp (if #f #f)))      ; read error, pass
+           ((eq? exp meta-command-token)
+            (with-backtrace (meta-command repl)))
+           ((eof-object? exp)
+            (newline)
+            (set! status '()))
+           (else
+            ;; since the input port is line-buffered, consume up to the
+            ;; newline
+            (flush-to-newline)
+            (with-backtrace
+             (catch 'quit
+               (lambda ()
+                 (call-with-values
+                     (lambda ()
+                       (run-hook before-eval-hook exp)
+                       (start-stack #t
+                                    (repl-eval repl (repl-parse repl exp))))
+                   (lambda l
+                     (for-each (lambda (v)
+                                 (run-hook before-print-hook v)
+                                 (repl-print repl v))
+                               l))))
+               (lambda (k . args)
+                 (set! status args))))))
+          (or status
+              (begin
+                (next-char #f) ;; consume trailing whitespace
+                (prompt-loop))))))))
 
 (define (next-char wait)
   (if (or wait (char-ready?))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index d5a4ac78f..6291e40cf 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -21,6 +21,7 @@
 (define-module (system vm debug)
   #:use-module (system base pmatch)
   #:use-module (system base syntax)
+  #:use-module (system base language)
   #:use-module (system vm vm)
   #:use-module (system vm frame)
   #:use-module (ice-9 rdelim)
@@ -139,6 +140,15 @@
                               #:per-line-prefix "     "))
             (lp (+ i inc) (or file last-file)))))))
 
+(define (frame->module frame)
+  (let ((proc (frame-procedure frame)))
+    (if (program? proc)
+        (let* ((mod (or (program-module proc) (current-module )))
+               (mod* (make-module)))
+          (module-use! mod* mod)
+          mod*)
+        (current-module))))
+
 
 ;;;
 ;;; Debugger
@@ -289,6 +299,13 @@ With an argument, select a frame by index, then show it."
             (format #t "No such frame.~%"))))
          (else (show-frame))))
 
+      (define-command ((commands repl r))
+        "Run a new REPL in the context of the current frame."
+        (save-module-excursion
+         (lambda ()
+           (set-current-module (frame->module cur))
+           ((@ (system repl repl) start-repl)))))
+
       (define-command ((commands procedure proc))
         "Print the procedure for the selected frame."
         (print* (frame-procedure cur)))