mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

recursive repl support

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-06-01 23:06:25 +02:00
parent 4288533bb3
commit 3098986b1a
3 changed files with 65 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

11
module/system/repl/common.scm
View file

@ -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)

75
module/system/repl/repl.scm
View file

@ -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?))

17
module/system/vm/debug.scm
View file

@ -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)))