Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Read-Eval-Print Loop |
2 | ||
5745de91 | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. |
17e90c5e | 4 | |
eb721799 AW |
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. | |
17e90c5e | 9 | ;; |
eb721799 | 10 | ;; This library is distributed in the hope that it will be useful, |
17e90c5e | 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
eb721799 AW |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;; Lesser General Public License for more details. | |
17e90c5e | 14 | ;; |
eb721799 AW |
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 | |
18 | ;; 02110-1301 USA | |
17e90c5e KN |
19 | |
20 | ;;; Code: | |
21 | ||
22 | (define-module (system repl repl) | |
8239263f | 23 | #:use-module (system base syntax) |
1a1a10d3 AW |
24 | #:use-module (system base pmatch) |
25 | #:use-module (system base compile) | |
26 | #:use-module (system base language) | |
33df2ec7 AW |
27 | #:use-module (system vm vm) |
28 | #:use-module (system repl error-handling) | |
1a1a10d3 AW |
29 | #:use-module (system repl common) |
30 | #:use-module (system repl command) | |
3ae78d95 AW |
31 | #:use-module (ice-9 control) |
32 | #:export (start-repl run-repl)) | |
17e90c5e | 33 | |
33df2ec7 | 34 | \f |
65fa60ca AW |
35 | ;;; |
36 | ;;; Comments | |
37 | ;;; | |
38 | ;;; (You don't want a comment to force a continuation line.) | |
39 | ;;; | |
40 | ||
41 | (define (read-scheme-line-comment port) | |
42 | (let lp () | |
43 | (let ((ch (read-char port))) | |
44 | (or (eof-object? ch) | |
45 | (eqv? ch #\newline) | |
46 | (lp))))) | |
47 | ||
48 | (define (read-scheme-datum-comment port) | |
49 | (read port)) | |
50 | ||
51 | ;; ch is a peeked char | |
52 | (define (read-comment lang port ch) | |
53 | (and (eq? (language-name lang) 'scheme) | |
54 | (case ch | |
55 | ((#\;) | |
56 | (read-char port) | |
57 | (read-scheme-line-comment port) | |
58 | #t) | |
59 | ((#\#) | |
60 | (read-char port) | |
61 | (case (peek-char port) | |
62 | ((#\;) | |
63 | (read-char port) | |
64 | (read-scheme-datum-comment port) | |
65 | #t) | |
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 | |
69 | ;; #!r6rs. | |
70 | (else | |
71 | (unread-char #\# port) | |
72 | #f))) | |
73 | (else | |
74 | #f)))) | |
75 | ||
76 | \f | |
33df2ec7 AW |
77 | |
78 | ;;; | |
79 | ;;; Meta commands | |
80 | ;;; | |
81 | ||
3a6f6678 AW |
82 | (define meta-command-token (cons 'meta 'command)) |
83 | ||
65fa60ca | 84 | (define (meta-reader lang env) |
c372cd74 AW |
85 | (lambda* (#:optional (port (current-input-port))) |
86 | (with-input-from-port port | |
87 | (lambda () | |
859e58ae | 88 | (let ((ch (flush-leading-whitespace))) |
c372cd74 | 89 | (cond ((eof-object? ch) |
7520a9b9 | 90 | (read-char)) ; consume the EOF and return it |
c372cd74 | 91 | ((eqv? ch #\,) |
7520a9b9 | 92 | (read-char) |
c372cd74 | 93 | meta-command-token) |
65fa60ca AW |
94 | ((read-comment lang port ch) |
95 | *unspecified*) | |
96 | (else ((language-reader lang) port env)))))))) | |
3a6f6678 | 97 | |
dcb7c7dd AW |
98 | (define (flush-all-input) |
99 | (if (and (char-ready?) | |
100 | (not (eof-object? (peek-char)))) | |
101 | (begin | |
102 | (read-char) | |
103 | (flush-all-input)))) | |
104 | ||
3a6f6678 AW |
105 | ;; repl-reader is a function defined in boot-9.scm, and is replaced by |
106 | ;; something else if readline has been activated. much of this hoopla is | |
107 | ;; to be able to re-use the existing readline machinery. | |
b93c34c0 AW |
108 | ;; |
109 | ;; Catches read errors, returning *unspecified* in that case. | |
3a6f6678 | 110 | (define (prompting-meta-read repl) |
33df2ec7 AW |
111 | (catch #t |
112 | (lambda () | |
113 | (repl-reader (lambda () (repl-prompt repl)) | |
65fa60ca | 114 | (meta-reader (repl-language repl) (current-module)))) |
33df2ec7 AW |
115 | (lambda (key . args) |
116 | (case key | |
117 | ((quit) | |
118 | (apply throw key args)) | |
119 | (else | |
eaba53b7 AW |
120 | (format (current-output-port) "While reading expression:\n") |
121 | (print-exception (current-output-port) #f key args) | |
dcb7c7dd | 122 | (flush-all-input) |
33df2ec7 | 123 | *unspecified*))))) |
67c4505e | 124 | |
652f48c0 AW |
125 | \f |
126 | ||
127 | ;;; | |
128 | ;;; The repl | |
129 | ;;; | |
130 | ||
33df2ec7 | 131 | (define* (start-repl #:optional (lang (current-language)) #:key debug) |
5745de91 AW |
132 | ;; ,language at the REPL will update the current-language. Make |
133 | ;; sure that it does so in a new dynamic scope. | |
134 | (parameterize ((current-language lang)) | |
2aef6c2b | 135 | (run-repl (make-repl lang debug)))) |
33df2ec7 | 136 | |
ffe911f7 | 137 | ;; (put 'abort-on-error 'scheme-indent-function 1) |
0c65f52c AW |
138 | (define-syntax-rule (abort-on-error string exp) |
139 | (catch #t | |
140 | (lambda () exp) | |
141 | (lambda (key . args) | |
142 | (format #t "While ~A:~%" string) | |
143 | (print-exception (current-output-port) #f key args) | |
144 | (abort)))) | |
ffe911f7 | 145 | |
33df2ec7 | 146 | (define (run-repl repl) |
52738540 AW |
147 | (define (with-stack-and-prompt thunk) |
148 | (call-with-prompt (default-prompt-tag) | |
149 | (lambda () (start-stack #t (thunk))) | |
150 | (lambda (k proc) | |
151 | (with-stack-and-prompt (lambda () (proc k)))))) | |
152 | ||
3ae78d95 AW |
153 | (% (with-fluids ((*repl-stack* |
154 | (cons repl (or (fluid-ref *repl-stack*) '())))) | |
155 | (if (null? (cdr (fluid-ref *repl-stack*))) | |
156 | (repl-welcome repl)) | |
157 | (let prompt-loop () | |
158 | (let ((exp (prompting-meta-read repl))) | |
159 | (cond | |
65fa60ca | 160 | ((eqv? exp *unspecified*)) ; read error or comment, pass |
3ae78d95 | 161 | ((eq? exp meta-command-token) |
5bc97ad5 AW |
162 | (catch #t |
163 | (lambda () | |
164 | (meta-command repl)) | |
3ae78d95 | 165 | (lambda (k . args) |
5bc97ad5 AW |
166 | (if (eq? k 'quit) |
167 | (abort args) | |
168 | (begin | |
a627100b | 169 | (format #t "While executing meta-command:~%") |
eaba53b7 | 170 | (print-exception (current-output-port) #f k args)))))) |
3ae78d95 AW |
171 | ((eof-object? exp) |
172 | (newline) | |
173 | (abort '())) | |
174 | (else | |
175 | ;; since the input port is line-buffered, consume up to the | |
176 | ;; newline | |
177 | (flush-to-newline) | |
178 | (call-with-error-handling | |
179 | (lambda () | |
180 | (catch 'quit | |
181 | (lambda () | |
182 | (call-with-values | |
183 | (lambda () | |
ffe911f7 AW |
184 | (% (let ((thunk |
185 | (abort-on-error "compiling expression" | |
186 | (repl-prepare-eval-thunk | |
187 | repl | |
188 | (abort-on-error "parsing expression" | |
189 | (repl-parse repl exp)))))) | |
190 | (run-hook before-eval-hook exp) | |
bb455e4f AW |
191 | (call-with-error-handling |
192 | (lambda () | |
193 | (with-stack-and-prompt thunk)) | |
194 | #:on-error (repl-option-ref repl 'on-error))) | |
ffe911f7 | 195 | (lambda (k) (values)))) |
3ae78d95 AW |
196 | (lambda l |
197 | (for-each (lambda (v) | |
198 | (repl-print repl v)) | |
199 | l)))) | |
200 | (lambda (k . args) | |
b0e556d4 | 201 | (abort args)))) |
bb455e4f | 202 | #:on-error (repl-option-ref repl 'on-error) |
b0e556d4 | 203 | #:trap-handler 'disabled))) |
859e58ae | 204 | (flush-to-newline) ;; consume trailing whitespace |
3ae78d95 | 205 | (prompt-loop)))) |
33df2ec7 | 206 | (lambda (k status) |
3ae78d95 | 207 | status))) |
17e90c5e | 208 | |
859e58ae AW |
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)) | |
214 | (else ch)))) | |
0d646345 AW |
215 | |
216 | (define (flush-to-newline) | |
217 | (if (char-ready?) | |
218 | (let ((ch (peek-char))) | |
219 | (if (and (not (eof-object? ch)) (char-whitespace? ch)) | |
220 | (begin | |
221 | (read-char) | |
222 | (if (not (char=? ch #\newline)) | |
223 | (flush-to-newline))))))) |