diff options
-rw-r--r-- | module/system/repl/common.scm | 11 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 75 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 17 |
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))) |