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) | |
23 | :use-syntax (system base syntax) | |
9cd17db7 | 24 | :use-module (system base pmatch) |
3a6f6678 AW |
25 | :use-module (system base compile) |
26 | :use-module (system base language) | |
17e90c5e KN |
27 | :use-module (system repl common) |
28 | :use-module (system repl command) | |
07e56b27 | 29 | :use-module (system vm vm) |
22bcbe8c | 30 | :use-module (system vm debug) |
17e90c5e | 31 | :use-module (ice-9 rdelim) |
7e4760e4 | 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 () | |
41 | (if (eqv? (next-char #t) #\,) | |
42 | (begin (read-char) meta-command-token) | |
43 | (read)))))) | |
3a6f6678 AW |
44 | |
45 | ;; repl-reader is a function defined in boot-9.scm, and is replaced by | |
46 | ;; something else if readline has been activated. much of this hoopla is | |
47 | ;; to be able to re-use the existing readline machinery. | |
48 | (define (prompting-meta-read repl) | |
49 | (let ((prompt (lambda () (repl-prompt repl))) | |
db917b41 | 50 | (lread (language-reader (repl-language repl)))) |
3a6f6678 AW |
51 | (with-fluid* current-reader (meta-reader lread) |
52 | (lambda () (repl-reader (lambda () (repl-prompt repl))))))) | |
53 | ||
9cd17db7 AW |
54 | (define (default-pre-unwind-handler key . args) |
55 | (save-stack default-pre-unwind-handler) | |
68a2e18a | 56 | (vm-save-stack (the-vm)) |
9cd17db7 AW |
57 | (apply throw key args)) |
58 | ||
59 | (define (default-catch-handler . args) | |
60 | (pmatch args | |
61 | ((quit . _) | |
62 | (apply throw args)) | |
63 | ((vm-error ,fun ,msg ,args) | |
22bcbe8c | 64 | (vm-backtrace (the-vm)) |
fbea69ad AW |
65 | (display "\nVM error: \n") |
66 | (apply format #t msg args) | |
9cd17db7 AW |
67 | (newline)) |
68 | ((,key ,subr ,msg ,args . ,rest) | |
68a2e18a AW |
69 | (vm-backtrace (the-vm)) |
70 | (newline) | |
9cd17db7 AW |
71 | (let ((cep (current-error-port))) |
72 | (cond ((not (stack? (fluid-ref the-last-stack)))) | |
73 | ((memq 'backtrace (debug-options-interface)) | |
74 | (let ((highlights (if (or (eq? key 'wrong-type-arg) | |
75 | (eq? key 'out-of-range)) | |
76 | (car rest) | |
77 | '()))) | |
78 | (run-hook before-backtrace-hook) | |
79 | (newline cep) | |
80 | (display "Backtrace:\n") | |
81 | (display-backtrace (fluid-ref the-last-stack) cep | |
82 | #f #f highlights) | |
83 | (newline cep) | |
84 | (run-hook after-backtrace-hook)))) | |
85 | (run-hook before-error-hook) | |
86 | (apply display-error (fluid-ref the-last-stack) cep subr msg args rest) | |
87 | (run-hook after-error-hook) | |
88 | (set! stack-saved? #f) | |
89 | (force-output cep))) | |
90 | (else | |
91 | (apply bad-throw args)))) | |
92 | ||
67c4505e AW |
93 | (define (call-with-backtrace thunk) |
94 | (catch #t | |
95 | thunk | |
96 | default-catch-handler | |
97 | default-pre-unwind-handler)) | |
98 | ||
d79d908e AW |
99 | (eval-case |
100 | ((compile-toplevel) | |
101 | (define-macro (start-stack tag expr) | |
102 | expr))) | |
103 | ||
17e90c5e KN |
104 | (define (start-repl lang) |
105 | (let ((repl (make-repl lang))) | |
17e90c5e KN |
106 | (repl-welcome repl) |
107 | (let prompt-loop () | |
3a6f6678 AW |
108 | (let ((exp (prompting-meta-read repl))) |
109 | (cond | |
110 | ((eq? exp meta-command-token) | |
67c4505e AW |
111 | (call-with-backtrace |
112 | (lambda () | |
113 | (meta-command repl (read-line))))) | |
3a6f6678 AW |
114 | ((eof-object? exp) |
115 | (throw 'quit)) | |
116 | (else | |
67c4505e AW |
117 | (call-with-backtrace |
118 | (lambda () | |
119 | (call-with-values (lambda () | |
120 | (run-hook before-eval-hook exp) | |
121 | (start-stack repl-eval | |
122 | (repl-eval repl exp))) | |
123 | (lambda l | |
124 | (for-each (lambda (v) | |
125 | (run-hook before-print-hook v) | |
126 | (repl-print repl v)) | |
127 | l))))))) | |
3a6f6678 AW |
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))) | |
134 | (cond ((eof-object? ch) (throw 'quit)) | |
135 | ((char-whitespace? ch) (read-char) (next-char wait)) | |
136 | (else ch))) | |
137 | #f)) |