Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Read-Eval-Print Loop |
2 | ||
eb721799 | 3 | ;; Copyright (C) 2001, 2009 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) | |
27 | #:use-module (system repl common) | |
28 | #:use-module (system repl command) | |
29 | #:use-module (system vm vm) | |
30 | #:use-module (system vm debug) | |
1a1a10d3 | 31 | #:export (start-repl call-with-backtrace)) |
17e90c5e | 32 | |
3a6f6678 AW |
33 | (define meta-command-token (cons 'meta 'command)) |
34 | ||
35 | (define (meta-reader read) | |
36fb1e06 AW |
36 | (lambda read-args |
37 | (with-input-from-port | |
38 | (if (pair? read-args) (car read-args) (current-input-port)) | |
39 | (lambda () | |
abf780e4 AW |
40 | (let ((ch (next-char #t))) |
41 | (cond ((eof-object? ch) | |
42 | ;; apparently sometimes even if this is eof, read will | |
43 | ;; wait on somethingorother. strange. | |
44 | ch) | |
c15fa41c | 45 | ((eqv? ch #\,) |
abf780e4 AW |
46 | (read-char) |
47 | meta-command-token) | |
48 | (else (read)))))))) | |
3a6f6678 AW |
49 | |
50 | ;; repl-reader is a function defined in boot-9.scm, and is replaced by | |
51 | ;; something else if readline has been activated. much of this hoopla is | |
52 | ;; to be able to re-use the existing readline machinery. | |
53 | (define (prompting-meta-read repl) | |
54 | (let ((prompt (lambda () (repl-prompt repl))) | |
db917b41 | 55 | (lread (language-reader (repl-language repl)))) |
3a6f6678 AW |
56 | (with-fluid* current-reader (meta-reader lread) |
57 | (lambda () (repl-reader (lambda () (repl-prompt repl))))))) | |
58 | ||
9cd17db7 AW |
59 | (define (default-catch-handler . args) |
60 | (pmatch args | |
61 | ((quit . _) | |
62 | (apply throw args)) | |
9cd17db7 AW |
63 | ((,key ,subr ,msg ,args . ,rest) |
64 | (let ((cep (current-error-port))) | |
65 | (cond ((not (stack? (fluid-ref the-last-stack)))) | |
66 | ((memq 'backtrace (debug-options-interface)) | |
67 | (let ((highlights (if (or (eq? key 'wrong-type-arg) | |
68 | (eq? key 'out-of-range)) | |
69 | (car rest) | |
70 | '()))) | |
71 | (run-hook before-backtrace-hook) | |
72 | (newline cep) | |
73 | (display "Backtrace:\n") | |
74 | (display-backtrace (fluid-ref the-last-stack) cep | |
75 | #f #f highlights) | |
76 | (newline cep) | |
77 | (run-hook after-backtrace-hook)))) | |
78 | (run-hook before-error-hook) | |
1e6ebf54 | 79 | (display-error (fluid-ref the-last-stack) cep subr msg args rest) |
9cd17db7 AW |
80 | (run-hook after-error-hook) |
81 | (set! stack-saved? #f) | |
82 | (force-output cep))) | |
83 | (else | |
1bb6b839 AW |
84 | (format (current-error-port) "\nERROR: uncaught throw to `~a', args: ~a\n" |
85 | (car args) (cdr args))))) | |
9cd17db7 | 86 | |
67c4505e AW |
87 | (define (call-with-backtrace thunk) |
88 | (catch #t | |
9f0e9918 | 89 | (lambda () (%start-stack #t thunk)) |
67c4505e | 90 | default-catch-handler |
1351c2db | 91 | default-pre-unwind-handler)) |
9f0e9918 AW |
92 | |
93 | (define-macro (with-backtrace form) | |
94 | `(call-with-backtrace (lambda () ,form))) | |
67c4505e | 95 | |
17e90c5e | 96 | (define (start-repl lang) |
6a01fabf AW |
97 | (let ((repl (make-repl lang)) |
98 | (status #f)) | |
17e90c5e KN |
99 | (repl-welcome repl) |
100 | (let prompt-loop () | |
9f0e9918 | 101 | (let ((exp (with-backtrace (prompting-meta-read repl)))) |
3a6f6678 | 102 | (cond |
482015af | 103 | ((eqv? exp (if #f #f))) ; read error, pass |
3a6f6678 | 104 | ((eq? exp meta-command-token) |
eb721799 | 105 | (with-backtrace (meta-command repl))) |
3a6f6678 | 106 | ((eof-object? exp) |
6a01fabf AW |
107 | (newline) |
108 | (set! status '())) | |
3a6f6678 | 109 | (else |
0d646345 AW |
110 | ;; since the input port is line-buffered, consume up to the |
111 | ;; newline | |
112 | (flush-to-newline) | |
9f0e9918 AW |
113 | (with-backtrace |
114 | (catch 'quit | |
115 | (lambda () | |
116 | (call-with-values | |
117 | (lambda () | |
118 | (run-hook before-eval-hook exp) | |
119 | (start-stack #t | |
120 | (repl-eval repl (repl-parse repl exp)))) | |
121 | (lambda l | |
122 | (for-each (lambda (v) | |
123 | (run-hook before-print-hook v) | |
124 | (repl-print repl v)) | |
125 | l)))) | |
126 | (lambda (k . args) | |
127 | (set! status args)))))) | |
6a01fabf AW |
128 | (or status |
129 | (begin | |
130 | (next-char #f) ;; consume trailing whitespace | |
131 | (prompt-loop))))))) | |
17e90c5e KN |
132 | |
133 | (define (next-char wait) | |
134 | (if (or wait (char-ready?)) | |
135 | (let ((ch (peek-char))) | |
d600df9a | 136 | (cond ((eof-object? ch) ch) |
17e90c5e KN |
137 | ((char-whitespace? ch) (read-char) (next-char wait)) |
138 | (else ch))) | |
139 | #f)) | |
0d646345 AW |
140 | |
141 | (define (flush-to-newline) | |
142 | (if (char-ready?) | |
143 | (let ((ch (peek-char))) | |
144 | (if (and (not (eof-object? ch)) (char-whitespace? ch)) | |
145 | (begin | |
146 | (read-char) | |
147 | (if (not (char=? ch #\newline)) | |
148 | (flush-to-newline))))))) | |
149 | ||
150 |