1 ;;; Read-Eval-Print Loop
3 ;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 3 of the License, or (at your option) any later version.
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 (define-module (system repl repl)
23 #:use-module (system base syntax)
24 #:use-module (system base pmatch)
25 #:use-module (system base compile)
26 #:use-module (system base language)
27 #:use-module (system vm vm)
28 #:use-module (system repl error-handling)
29 #:use-module (system repl common)
30 #:use-module (system repl command)
31 #:use-module (ice-9 control)
32 #:export (start-repl run-repl))
40 (define meta-command-token (cons 'meta 'command))
42 (define (meta-reader read env)
44 (let ((port (if (pair? read-args) (car read-args) (current-input-port))))
45 (with-input-from-port port
47 (let ((ch (next-char #t)))
48 (cond ((eof-object? ch)
49 ;; EOF objects are not buffered. It's quite possible
50 ;; to peek an EOF then read something else. It's
51 ;; strange but it's how it works.
56 (else (read port env)))))))))
58 ;; repl-reader is a function defined in boot-9.scm, and is replaced by
59 ;; something else if readline has been activated. much of this hoopla is
60 ;; to be able to re-use the existing readline machinery.
62 ;; Catches read errors, returning *unspecified* in that case.
63 (define (prompting-meta-read repl)
66 (repl-reader (lambda () (repl-prompt repl))
67 (meta-reader (language-reader (repl-language repl))
72 (apply throw key args))
75 ((,subr ,msg ,args . ,rest)
76 (format #t "Throw to key `~a' while reading expression:\n" key)
77 (display-error #f (current-output-port) subr msg args rest))
79 (format #t "Throw to key `~a' with args `~s' while reading expression.\n"
90 (define* (start-repl #:optional (lang (current-language)) #:key debug)
91 (run-repl (make-repl lang debug)))
93 ;; (put 'abort-on-error 'scheme-indent-function 1)
94 (define-syntax abort-on-error
100 (format #t "While ~A:~%" string)
102 ((,subr ,msg ,args . ,rest)
103 (display-error #f (current-output-port) subr msg args rest))
105 (format #t "ERROR: Throw to key `~a' with args `~s'.\n" key args)))
109 (define (run-repl repl)
110 (define (with-stack-and-prompt thunk)
111 (call-with-prompt (default-prompt-tag)
112 (lambda () (start-stack #t (thunk)))
114 (with-stack-and-prompt (lambda () (proc k))))))
116 (% (with-fluids ((*repl-stack*
117 (cons repl (or (fluid-ref *repl-stack*) '()))))
118 (if (null? (cdr (fluid-ref *repl-stack*)))
121 (let ((exp (prompting-meta-read repl)))
123 ((eqv? exp *unspecified*)) ; read error, pass
124 ((eq? exp meta-command-token)
132 (format #t "While executing meta-command `~A'~%" string)
134 ((,subr ,msg ,args . ,rest)
135 (display-error #f (current-output-port) subr msg args rest))
137 (format #t "ERROR: Throw to key `~a' with args `~s'.\n" k args)))
143 ;; since the input port is line-buffered, consume up to the
146 (call-with-error-handling
153 (abort-on-error "compiling expression"
154 (repl-prepare-eval-thunk
156 (abort-on-error "parsing expression"
157 (repl-parse repl exp))))))
158 (run-hook before-eval-hook exp)
160 (with-stack-and-prompt thunk)))
161 (lambda (k) (values))))
163 (for-each (lambda (v)
168 #:trap-handler 'disabled)))
169 (next-char #f) ;; consume trailing whitespace
174 (define (next-char wait)
175 (if (or wait (char-ready?))
176 (let ((ch (peek-char)))
177 (cond ((eof-object? ch) ch)
178 ((char-whitespace? ch) (read-char) (next-char wait))
182 (define (flush-to-newline)
184 (let ((ch (peek-char)))
185 (if (and (not (eof-object? ch)) (char-whitespace? ch))
188 (if (not (char=? ch #\newline))
189 (flush-to-newline)))))))