1 ;;; Read-Eval-Print Loop
3 ;; Copyright (C) 2001, 2009, 2010, 2011 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))
38 ;;; (You don't want a comment to force a continuation line.)
41 (define (read-scheme-line-comment port)
43 (let ((ch (read-char port)))
48 (define (read-scheme-datum-comment port)
51 ;; ch is a peeked char
52 (define (read-comment lang port ch)
53 (and (eq? (language-name lang) 'scheme)
57 (read-scheme-line-comment port)
61 (case (peek-char port)
64 (read-scheme-datum-comment port)
66 ;; Not doing R6RS block comments because of the possibility
67 ;; of read-hash extensions. Lame excuse. Not doing scsh
68 ;; block comments either, because I don't feel like handling
71 (unread-char #\# port)
82 (define meta-command-token (cons 'meta 'command))
84 (define (meta-reader lang env)
85 (lambda* (#:optional (port (current-input-port)))
86 (with-input-from-port port
88 (let ((ch (flush-leading-whitespace)))
89 (cond ((eof-object? ch)
90 ;; EOF objects are not buffered. It's quite possible
91 ;; to peek an EOF then read something else. It's
92 ;; strange but it's how it works.
97 ((read-comment lang port ch)
99 (else ((language-reader lang) port env))))))))
101 (define (flush-all-input)
102 (if (and (char-ready?)
103 (not (eof-object? (peek-char))))
108 ;; repl-reader is a function defined in boot-9.scm, and is replaced by
109 ;; something else if readline has been activated. much of this hoopla is
110 ;; to be able to re-use the existing readline machinery.
112 ;; Catches read errors, returning *unspecified* in that case.
113 (define (prompting-meta-read repl)
116 (repl-reader (lambda () (repl-prompt repl))
117 (meta-reader (repl-language repl) (current-module))))
121 (apply throw key args))
123 (format (current-output-port) "While reading expression:\n")
124 (print-exception (current-output-port) #f key args)
134 (define* (start-repl #:optional (lang (current-language)) #:key debug)
135 (run-repl (make-repl lang debug)))
137 ;; (put 'abort-on-error 'scheme-indent-function 1)
138 (define-syntax-rule (abort-on-error string exp)
142 (format #t "While ~A:~%" string)
143 (print-exception (current-output-port) #f key args)
146 (define (run-repl repl)
147 (define (with-stack-and-prompt thunk)
148 (call-with-prompt (default-prompt-tag)
149 (lambda () (start-stack #t (thunk)))
151 (with-stack-and-prompt (lambda () (proc k))))))
153 (% (with-fluids ((*repl-stack*
154 (cons repl (or (fluid-ref *repl-stack*) '()))))
155 (if (null? (cdr (fluid-ref *repl-stack*)))
158 (let ((exp (prompting-meta-read repl)))
160 ((eqv? exp *unspecified*)) ; read error or comment, pass
161 ((eq? exp meta-command-token)
169 (format #t "While executing meta-command:~%")
170 (print-exception (current-output-port) #f k args))))))
175 ;; since the input port is line-buffered, consume up to the
178 (call-with-error-handling
185 (abort-on-error "compiling expression"
186 (repl-prepare-eval-thunk
188 (abort-on-error "parsing expression"
189 (repl-parse repl exp))))))
190 (run-hook before-eval-hook exp)
191 (call-with-error-handling
193 (with-stack-and-prompt thunk))
194 #:on-error (repl-option-ref repl 'on-error)))
195 (lambda (k) (values))))
197 (for-each (lambda (v)
202 #:on-error (repl-option-ref repl 'on-error)
203 #:trap-handler 'disabled)))
204 (flush-to-newline) ;; consume trailing whitespace
209 ;; Returns first non-whitespace char.
210 (define (flush-leading-whitespace)
211 (let ((ch (peek-char)))
212 (cond ((eof-object? ch) ch)
213 ((char-whitespace? ch) (read-char) (flush-leading-whitespace))
216 (define (flush-to-newline)
218 (let ((ch (peek-char)))
219 (if (and (not (eof-object? ch)) (char-whitespace? ch))
222 (if (not (char=? ch #\newline))
223 (flush-to-newline)))))))