Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Read-Eval-Print Loop |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (system repl repl) | |
1a1a10d3 AW |
23 | #:use-syntax (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 repl common) | |
28 | #:use-module (system repl command) | |
29 | #:use-module (system vm vm) | |
30 | #:use-module (system vm debug) | |
31 | #:use-module (ice-9 rdelim) | |
32 | #:export (start-repl call-with-backtrace)) | |
17e90c5e | 33 | |
3a6f6678 AW |
34 | (define meta-command-token (cons 'meta 'command)) |
35 | ||
36 | (define (meta-reader read) | |
36fb1e06 AW |
37 | (lambda read-args |
38 | (with-input-from-port | |
39 | (if (pair? read-args) (car read-args) (current-input-port)) | |
40 | (lambda () | |
abf780e4 AW |
41 | (let ((ch (next-char #t))) |
42 | (cond ((eof-object? ch) | |
43 | ;; apparently sometimes even if this is eof, read will | |
44 | ;; wait on somethingorother. strange. | |
45 | ch) | |
46 | ((eqv? (char #\,)) | |
47 | (read-char) | |
48 | meta-command-token) | |
49 | (else (read)))))))) | |
3a6f6678 AW |
50 | |
51 | ;; repl-reader is a function defined in boot-9.scm, and is replaced by | |
52 | ;; something else if readline has been activated. much of this hoopla is | |
53 | ;; to be able to re-use the existing readline machinery. | |
54 | (define (prompting-meta-read repl) | |
55 | (let ((prompt (lambda () (repl-prompt repl))) | |
db917b41 | 56 | (lread (language-reader (repl-language repl)))) |
3a6f6678 AW |
57 | (with-fluid* current-reader (meta-reader lread) |
58 | (lambda () (repl-reader (lambda () (repl-prompt repl))))))) | |
59 | ||
9cd17db7 AW |
60 | (define (default-catch-handler . args) |
61 | (pmatch args | |
62 | ((quit . _) | |
63 | (apply throw args)) | |
9cd17db7 AW |
64 | ((,key ,subr ,msg ,args . ,rest) |
65 | (let ((cep (current-error-port))) | |
66 | (cond ((not (stack? (fluid-ref the-last-stack)))) | |
67 | ((memq 'backtrace (debug-options-interface)) | |
68 | (let ((highlights (if (or (eq? key 'wrong-type-arg) | |
69 | (eq? key 'out-of-range)) | |
70 | (car rest) | |
71 | '()))) | |
72 | (run-hook before-backtrace-hook) | |
73 | (newline cep) | |
74 | (display "Backtrace:\n") | |
75 | (display-backtrace (fluid-ref the-last-stack) cep | |
76 | #f #f highlights) | |
77 | (newline cep) | |
78 | (run-hook after-backtrace-hook)))) | |
79 | (run-hook before-error-hook) | |
1e6ebf54 | 80 | (display-error (fluid-ref the-last-stack) cep subr msg args rest) |
9cd17db7 AW |
81 | (run-hook after-error-hook) |
82 | (set! stack-saved? #f) | |
83 | (force-output cep))) | |
84 | (else | |
1bb6b839 AW |
85 | (format (current-error-port) "\nERROR: uncaught throw to `~a', args: ~a\n" |
86 | (car args) (cdr args))))) | |
9cd17db7 | 87 | |
67c4505e AW |
88 | (define (call-with-backtrace thunk) |
89 | (catch #t | |
9f0e9918 | 90 | (lambda () (%start-stack #t thunk)) |
67c4505e | 91 | default-catch-handler |
9f0e9918 AW |
92 | pre-unwind-handler-dispatch)) |
93 | ||
94 | (define-macro (with-backtrace form) | |
95 | `(call-with-backtrace (lambda () ,form))) | |
67c4505e | 96 | |
17e90c5e | 97 | (define (start-repl lang) |
6a01fabf AW |
98 | (let ((repl (make-repl lang)) |
99 | (status #f)) | |
17e90c5e KN |
100 | (repl-welcome repl) |
101 | (let prompt-loop () | |
9f0e9918 | 102 | (let ((exp (with-backtrace (prompting-meta-read repl)))) |
3a6f6678 | 103 | (cond |
482015af | 104 | ((eqv? exp (if #f #f))) ; read error, pass |
3a6f6678 | 105 | ((eq? exp meta-command-token) |
9f0e9918 | 106 | (with-backtrace (meta-command repl (read-line)))) |
3a6f6678 | 107 | ((eof-object? exp) |
6a01fabf AW |
108 | (newline) |
109 | (set! status '())) | |
3a6f6678 | 110 | (else |
9f0e9918 AW |
111 | (with-backtrace |
112 | (catch 'quit | |
113 | (lambda () | |
114 | (call-with-values | |
115 | (lambda () | |
116 | (run-hook before-eval-hook exp) | |
117 | (start-stack #t | |
118 | (repl-eval repl (repl-parse repl exp)))) | |
119 | (lambda l | |
120 | (for-each (lambda (v) | |
121 | (run-hook before-print-hook v) | |
122 | (repl-print repl v)) | |
123 | l)))) | |
124 | (lambda (k . args) | |
125 | (set! status args)))))) | |
6a01fabf AW |
126 | (or status |
127 | (begin | |
128 | (next-char #f) ;; consume trailing whitespace | |
129 | (prompt-loop))))))) | |
17e90c5e KN |
130 | |
131 | (define (next-char wait) | |
132 | (if (or wait (char-ready?)) | |
133 | (let ((ch (peek-char))) | |
d600df9a | 134 | (cond ((eof-object? ch) ch) |
17e90c5e KN |
135 | ((char-whitespace? ch) (read-char) (next-char wait)) |
136 | (else ch))) | |
137 | #f)) |