Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Read-Eval-Print Loop |
2 | ||
3098986b | 3 | ;; Copyright (C) 2001, 2009, 2010 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 AW |
34 | \f |
35 | ||
36 | ;;; | |
37 | ;;; Meta commands | |
38 | ;;; | |
39 | ||
3a6f6678 AW |
40 | (define meta-command-token (cons 'meta 'command)) |
41 | ||
4b2afc62 | 42 | (define (meta-reader read env) |
36fb1e06 | 43 | (lambda read-args |
4b2afc62 AW |
44 | (let ((port (if (pair? read-args) (car read-args) (current-input-port)))) |
45 | (with-input-from-port port | |
46 | (lambda () | |
47 | (let ((ch (next-char #t))) | |
48 | (cond ((eof-object? ch) | |
35c46aad AW |
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. | |
4b2afc62 AW |
52 | ch) |
53 | ((eqv? ch #\,) | |
54 | (read-char port) | |
55 | meta-command-token) | |
56 | (else (read port env))))))))) | |
3a6f6678 AW |
57 | |
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. | |
b93c34c0 AW |
61 | ;; |
62 | ;; Catches read errors, returning *unspecified* in that case. | |
3a6f6678 | 63 | (define (prompting-meta-read repl) |
33df2ec7 AW |
64 | (catch #t |
65 | (lambda () | |
66 | (repl-reader (lambda () (repl-prompt repl)) | |
67 | (meta-reader (language-reader (repl-language repl)) | |
68 | (current-module)))) | |
69 | (lambda (key . args) | |
70 | (case key | |
71 | ((quit) | |
72 | (apply throw key args)) | |
73 | (else | |
74 | (pmatch 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)) | |
78 | (else | |
79 | (format #t "Throw to key `~a' with args `~s' while reading expression.\n" | |
80 | key args))) | |
81 | (force-output) | |
82 | *unspecified*))))) | |
67c4505e | 83 | |
652f48c0 AW |
84 | \f |
85 | ||
86 | ;;; | |
87 | ;;; The repl | |
88 | ;;; | |
89 | ||
33df2ec7 AW |
90 | (define* (start-repl #:optional (lang (current-language)) #:key debug) |
91 | (run-repl (make-repl lang debug))) | |
92 | ||
ffe911f7 AW |
93 | ;; (put 'abort-on-error 'scheme-indent-function 1) |
94 | (define-syntax abort-on-error | |
95 | (syntax-rules () | |
96 | ((_ string exp) | |
97 | (catch #t | |
98 | (lambda () exp) | |
99 | (lambda (key . args) | |
100 | (format #t "While ~A:~%" string) | |
101 | (pmatch args | |
102 | ((,subr ,msg ,args . ,rest) | |
103 | (display-error #f (current-output-port) subr msg args rest)) | |
104 | (else | |
105 | (format #t "ERROR: Throw to key `~a' with args `~s'.\n" key args))) | |
106 | (force-output) | |
107 | (abort)))))) | |
108 | ||
33df2ec7 | 109 | (define (run-repl repl) |
52738540 AW |
110 | (define (with-stack-and-prompt thunk) |
111 | (call-with-prompt (default-prompt-tag) | |
112 | (lambda () (start-stack #t (thunk))) | |
113 | (lambda (k proc) | |
114 | (with-stack-and-prompt (lambda () (proc k)))))) | |
115 | ||
3ae78d95 AW |
116 | (% (with-fluids ((*repl-stack* |
117 | (cons repl (or (fluid-ref *repl-stack*) '())))) | |
118 | (if (null? (cdr (fluid-ref *repl-stack*))) | |
119 | (repl-welcome repl)) | |
120 | (let prompt-loop () | |
121 | (let ((exp (prompting-meta-read repl))) | |
122 | (cond | |
123 | ((eqv? exp *unspecified*)) ; read error, pass | |
124 | ((eq? exp meta-command-token) | |
5bc97ad5 AW |
125 | (catch #t |
126 | (lambda () | |
127 | (meta-command repl)) | |
3ae78d95 | 128 | (lambda (k . args) |
5bc97ad5 AW |
129 | (if (eq? k 'quit) |
130 | (abort args) | |
131 | (begin | |
a627100b | 132 | (format #t "While executing meta-command:~%") |
5bc97ad5 AW |
133 | (pmatch args |
134 | ((,subr ,msg ,args . ,rest) | |
135 | (display-error #f (current-output-port) subr msg args rest)) | |
136 | (else | |
ac37b82d | 137 | (format #t "ERROR: Throw to key `~a' with args `~s'.\n" k args))) |
5bc97ad5 | 138 | (force-output)))))) |
3ae78d95 AW |
139 | ((eof-object? exp) |
140 | (newline) | |
141 | (abort '())) | |
142 | (else | |
143 | ;; since the input port is line-buffered, consume up to the | |
144 | ;; newline | |
145 | (flush-to-newline) | |
146 | (call-with-error-handling | |
147 | (lambda () | |
148 | (catch 'quit | |
149 | (lambda () | |
150 | (call-with-values | |
151 | (lambda () | |
ffe911f7 AW |
152 | (% (let ((thunk |
153 | (abort-on-error "compiling expression" | |
154 | (repl-prepare-eval-thunk | |
155 | repl | |
156 | (abort-on-error "parsing expression" | |
157 | (repl-parse repl exp)))))) | |
158 | (run-hook before-eval-hook exp) | |
159 | (with-error-handling | |
52738540 | 160 | (with-stack-and-prompt thunk))) |
ffe911f7 | 161 | (lambda (k) (values)))) |
3ae78d95 AW |
162 | (lambda l |
163 | (for-each (lambda (v) | |
164 | (repl-print repl v)) | |
165 | l)))) | |
166 | (lambda (k . args) | |
b0e556d4 AW |
167 | (abort args)))) |
168 | #:trap-handler 'disabled))) | |
3ae78d95 AW |
169 | (next-char #f) ;; consume trailing whitespace |
170 | (prompt-loop)))) | |
33df2ec7 | 171 | (lambda (k status) |
3ae78d95 | 172 | status))) |
17e90c5e KN |
173 | |
174 | (define (next-char wait) | |
175 | (if (or wait (char-ready?)) | |
176 | (let ((ch (peek-char))) | |
78e836ef | 177 | (cond ((eof-object? ch) ch) |
17e90c5e KN |
178 | ((char-whitespace? ch) (read-char) (next-char wait)) |
179 | (else ch))) | |
180 | #f)) | |
0d646345 AW |
181 | |
182 | (define (flush-to-newline) | |
183 | (if (char-ready?) | |
184 | (let ((ch (peek-char))) | |
185 | (if (and (not (eof-object? ch)) (char-whitespace? ch)) | |
186 | (begin | |
187 | (read-char) | |
188 | (if (not (char=? ch #\newline)) | |
189 | (flush-to-newline))))))) |