mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 13:00:34 +02:00
Code Activity

tweaks to new repl

Browse source 
* module/system/repl/command.scm (read-command): Remove a pk.
* module/system/repl/repl.scm (run-repl): Export. Use % and abort to
  implement the prompt.
This commit is contained in:
Andy Wingo 2010-07-09 18:22:08 +02:00
parent 33df2ec719
commit 3ae78d95e6
2 changed files with 41 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

2
module/system/repl/command.scm
View file

@ -128,7 +128,7 @@
(define (read-command repl) (define (read-command repl)
(catch #t (catch #t
(lambda () (read (pk (repl-inport repl)))) (lambda () (read (repl-inport repl)))
(lambda (key . args) (lambda (key . args)
(pmatch args (pmatch args
((,subr ,msg ,args . ,rest) ((,subr ,msg ,args . ,rest)

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

@ -28,7 +28,8 @@
#:use-module (system repl error-handling) #:use-module (system repl error-handling)
#:use-module (system repl common) #:use-module (system repl common)
#:use-module (system repl command) #:use-module (system repl command)
#:export (start-repl)) #:use-module (ice-9 control)
#:export (start-repl run-repl))
@ -89,49 +90,45 @@
(run-repl (make-repl lang debug))) (run-repl (make-repl lang debug)))
(define (run-repl repl) (define (run-repl repl)
(let ((tag (make-prompt-tag "repl "))) (% (with-fluids ((*repl-stack*
(call-with-prompt (cons repl (or (fluid-ref *repl-stack*) '()))))
tag (if (null? (cdr (fluid-ref *repl-stack*)))
(lambda () (repl-welcome repl))
(with-fluids ((*repl-stack* (let prompt-loop ()
(cons repl (or (fluid-ref *repl-stack*) '())))) (let ((exp (prompting-meta-read repl)))
(if (null? (cdr (fluid-ref *repl-stack*))) (cond
(repl-welcome repl)) ((eqv? exp *unspecified*)) ; read error, pass
(let prompt-loop () ((eq? exp meta-command-token)
(let ((exp (prompting-meta-read repl))) (catch 'quit
(cond (lambda () (meta-command repl))
((eqv? exp *unspecified*)) ; read error, pass (lambda (k . args)
((eq? exp meta-command-token) (abort args))))
(catch 'quit ((eof-object? exp)
(lambda () (meta-command repl)) (newline)
(lambda (k . args) (abort '()))
(abort-to-prompt tag args)))) (else
((eof-object? exp) ;; since the input port is line-buffered, consume up to the
(newline) ;; newline
(abort-to-prompt tag '())) (flush-to-newline)
(else (call-with-error-handling
;; since the input port is line-buffered, consume up to the (lambda ()
;; newline (catch 'quit
(flush-to-newline) (lambda ()
(call-with-error-handling (call-with-values
(lambda () (lambda ()
(catch 'quit (run-hook before-eval-hook exp)
(lambda () (start-stack #t
(call-with-values (repl-eval repl (repl-parse repl exp))))
(lambda () (lambda l
(run-hook before-eval-hook exp) (for-each (lambda (v)
(start-stack #t (repl-print repl v))
(repl-eval repl (repl-parse repl exp)))) l))))
(lambda l (lambda (k . args)
(for-each (lambda (v) (abort args)))))))
(repl-print repl v)) (next-char #f) ;; consume trailing whitespace
l)))) (prompt-loop))))
(lambda (k . args)
(abort-to-prompt tag args)))))))
(next-char #f) ;; consume trailing whitespace
(prompt-loop)))))
(lambda (k status) (lambda (k status)
status)))) status)))
(define (next-char wait) (define (next-char wait)
(if (or wait (char-ready?)) (if (or wait (char-ready?))