Commit | Line | Data |
---|---|---|
28969427 | 1 | ;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2014 |
b2e27da3 AW |
2 | ;;;; Free Software Foundation, Inc. |
3 | ;;;; | |
4 | ;;;; This library is free software; you can redistribute it and/or | |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
7 | ;;;; version 3 of the License, or (at your option) any later version. | |
8 | ;;;; | |
9 | ;;;; This library is distributed in the hope that it will be useful, | |
10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | ;;;; Lesser General Public License for more details. | |
13 | ;;;; | |
14 | ;;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;;; License along with this library; if not, write to the Free Software | |
16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
17 | ;;;; | |
18 | ||
19 | (define-module (ice-9 scm-style-repl) | |
d8158b83 AW |
20 | #:use-module (ice-9 save-stack) |
21 | ||
40f17f1e AW |
22 | #:export (scm-repl-silent |
23 | scm-repl-print-unspecified | |
24 | scm-repl-verbose | |
28969427 AW |
25 | scm-repl-prompt |
26 | assert-repl-silence | |
27 | assert-repl-print-unspecified | |
28 | assert-repl-verbosity | |
40f17f1e | 29 | |
28969427 AW |
30 | default-pre-unwind-handler |
31 | bad-throw | |
32 | error-catching-loop | |
33 | error-catching-repl | |
34 | scm-style-repl | |
35 | handle-system-error)) | |
b2e27da3 | 36 | |
40f17f1e AW |
37 | (define scm-repl-silent #f) |
38 | (define (assert-repl-silence v) (set! scm-repl-silent v)) | |
39 | ||
40 | (define scm-repl-print-unspecified #f) | |
41 | (define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v)) | |
42 | ||
43 | (define scm-repl-verbose #f) | |
44 | (define (assert-repl-verbosity v) (set! scm-repl-verbose v)) | |
45 | ||
46 | (define scm-repl-prompt "guile> ") | |
47 | ||
48 | \f | |
49 | ||
4100dc5d AW |
50 | ;; bad-throw is the hook that is called upon a throw to a an unhandled |
51 | ;; key (unless the throw has four arguments, in which case | |
52 | ;; it's usually interpreted as an error throw.) | |
53 | ;; If the key has a default handler (a throw-handler-default property), | |
54 | ;; it is applied to the throw. | |
55 | ;; | |
56 | (define (bad-throw key . args) | |
57 | (let ((default (symbol-property key 'throw-handler-default))) | |
58 | (or (and default (apply default key args)) | |
59 | (apply error "unhandled-exception:" key args)))) | |
60 | ||
61 | \f | |
62 | ||
fede5c89 AW |
63 | (define (default-pre-unwind-handler key . args) |
64 | ;; Narrow by two more frames: this one, and the throw handler. | |
65 | (save-stack 2) | |
66 | (apply throw key args)) | |
67 | ||
68 | \f | |
69 | ||
352b99c4 AW |
70 | (define has-shown-debugger-hint? #f) |
71 | ||
b2e27da3 AW |
72 | (define (error-catching-loop thunk) |
73 | (let ((status #f) | |
74 | (interactive #t)) | |
75 | (define (loop first) | |
76 | (let ((next | |
77 | (catch #t | |
78 | ||
79 | (lambda () | |
80 | (call-with-unblocked-asyncs | |
81 | (lambda () | |
925c1bae AW |
82 | (first) |
83 | ||
84 | ;; This line is needed because mark | |
85 | ;; doesn't do closures quite right. | |
86 | ;; Unreferenced locals should be | |
87 | ;; collected. | |
88 | (set! first #f) | |
89 | (let loop ((v (thunk))) | |
90 | (loop (thunk))) | |
91 | #f))) | |
b2e27da3 AW |
92 | |
93 | (lambda (key . args) | |
94 | (case key | |
95 | ((quit) | |
96 | (set! status args) | |
97 | #f) | |
98 | ||
99 | ((switch-repl) | |
100 | (apply throw 'switch-repl args)) | |
101 | ||
102 | ((abort) | |
103 | ;; This is one of the closures that require | |
104 | ;; (set! first #f) above | |
105 | ;; | |
106 | (lambda () | |
107 | (run-hook abort-hook) | |
108 | (force-output (current-output-port)) | |
109 | (display "ABORT: " (current-error-port)) | |
110 | (write args (current-error-port)) | |
111 | (newline (current-error-port)) | |
112 | (if interactive | |
113 | (begin | |
114 | (if (and | |
115 | (not has-shown-debugger-hint?) | |
116 | (not (memq 'backtrace | |
117 | (debug-options-interface))) | |
118 | (stack? (fluid-ref the-last-stack))) | |
119 | (begin | |
120 | (newline (current-error-port)) | |
121 | (display | |
122 | "Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n" | |
123 | (current-error-port)) | |
124 | (set! has-shown-debugger-hint? #t))) | |
125 | (force-output (current-error-port))) | |
126 | (begin | |
127 | (primitive-exit 1))) | |
128 | (set! stack-saved? #f))) | |
129 | ||
130 | (else | |
131 | ;; This is the other cons-leak closure... | |
132 | (lambda () | |
133 | (cond ((= (length args) 4) | |
134 | (apply handle-system-error key args)) | |
135 | (else | |
136 | (apply bad-throw key args))))))) | |
137 | ||
138 | default-pre-unwind-handler))) | |
139 | ||
140 | (if next (loop next) status))) | |
9346b857 AW |
141 | (set! ensure-batch-mode! (lambda () |
142 | (set! interactive #f) | |
143 | (restore-signals))) | |
b2e27da3 AW |
144 | (set! batch-mode? (lambda () (not interactive))) |
145 | (call-with-blocked-asyncs | |
146 | (lambda () (loop (lambda () #t)))))) | |
147 | ||
148 | (define (error-catching-repl r e p) | |
149 | (error-catching-loop | |
150 | (lambda () | |
151 | (call-with-values (lambda () (e (r))) | |
152 | (lambda the-values (for-each p the-values)))))) | |
153 | ||
154 | (define (scm-style-repl) | |
155 | (letrec ( | |
156 | (start-gc-rt #f) | |
157 | (start-rt #f) | |
158 | (repl-report-start-timing (lambda () | |
159 | (set! start-gc-rt (gc-run-time)) | |
160 | (set! start-rt (get-internal-run-time)))) | |
161 | (repl-report (lambda () | |
162 | (display ";;; ") | |
163 | (display (inexact->exact | |
164 | (* 1000 (/ (- (get-internal-run-time) start-rt) | |
165 | internal-time-units-per-second)))) | |
166 | (display " msec (") | |
167 | (display (inexact->exact | |
168 | (* 1000 (/ (- (gc-run-time) start-gc-rt) | |
169 | internal-time-units-per-second)))) | |
170 | (display " msec in gc)\n"))) | |
171 | ||
172 | (consume-trailing-whitespace | |
173 | (lambda () | |
174 | (let ((ch (peek-char))) | |
175 | (cond | |
176 | ((eof-object? ch)) | |
177 | ((or (char=? ch #\space) (char=? ch #\tab)) | |
178 | (read-char) | |
179 | (consume-trailing-whitespace)) | |
180 | ((char=? ch #\newline) | |
181 | (read-char)))))) | |
182 | (-read (lambda () | |
183 | (let ((val | |
184 | (let ((prompt (cond ((string? scm-repl-prompt) | |
185 | scm-repl-prompt) | |
186 | ((thunk? scm-repl-prompt) | |
187 | (scm-repl-prompt)) | |
188 | (scm-repl-prompt "> ") | |
189 | (else "")))) | |
190 | (repl-reader prompt)))) | |
191 | ||
192 | ;; As described in R4RS, the READ procedure updates the | |
193 | ;; port to point to the first character past the end of | |
194 | ;; the external representation of the object. This | |
195 | ;; means that it doesn't consume the newline typically | |
196 | ;; found after an expression. This means that, when | |
197 | ;; debugging Guile with GDB, GDB gets the newline, which | |
198 | ;; it often interprets as a "continue" command, making | |
199 | ;; breakpoints kind of useless. So, consume any | |
200 | ;; trailing newline here, as well as any whitespace | |
201 | ;; before it. | |
202 | ;; But not if EOF, for control-D. | |
203 | (if (not (eof-object? val)) | |
204 | (consume-trailing-whitespace)) | |
205 | (run-hook after-read-hook) | |
206 | (if (eof-object? val) | |
207 | (begin | |
208 | (repl-report-start-timing) | |
209 | (if scm-repl-verbose | |
210 | (begin | |
211 | (newline) | |
212 | (display ";;; EOF -- quitting") | |
213 | (newline))) | |
214 | (quit 0))) | |
215 | val))) | |
216 | ||
217 | (-eval (lambda (sourc) | |
218 | (repl-report-start-timing) | |
219 | (run-hook before-eval-hook sourc) | |
220 | (let ((val (start-stack 'repl-stack | |
221 | ;; If you change this procedure | |
222 | ;; (primitive-eval), please also | |
223 | ;; modify the repl-stack case in | |
224 | ;; save-stack so that stack cutting | |
225 | ;; continues to work. | |
226 | (primitive-eval sourc)))) | |
227 | (run-hook after-eval-hook sourc) | |
228 | val))) | |
229 | ||
230 | ||
231 | (-print (let ((maybe-print (lambda (result) | |
232 | (if (or scm-repl-print-unspecified | |
233 | (not (unspecified? result))) | |
234 | (begin | |
235 | (write result) | |
236 | (newline)))))) | |
237 | (lambda (result) | |
238 | (if (not scm-repl-silent) | |
239 | (begin | |
240 | (run-hook before-print-hook result) | |
241 | (maybe-print result) | |
242 | (run-hook after-print-hook result) | |
243 | (if scm-repl-verbose | |
244 | (repl-report)) | |
245 | (force-output)))))) | |
246 | ||
247 | (-quit (lambda (args) | |
248 | (if scm-repl-verbose | |
249 | (begin | |
250 | (display ";;; QUIT executed, repl exitting") | |
251 | (newline) | |
252 | (repl-report))) | |
253 | args))) | |
254 | ||
255 | (let ((status (error-catching-repl -read | |
256 | -eval | |
257 | -print))) | |
258 | (-quit status)))) | |
7034da24 AW |
259 | |
260 | (define (handle-system-error key . args) | |
261 | (let ((cep (current-error-port))) | |
262 | (cond ((not (stack? (fluid-ref the-last-stack)))) | |
263 | ((memq 'backtrace (debug-options-interface)) | |
264 | (let ((highlights (if (or (eq? key 'wrong-type-arg) | |
265 | (eq? key 'out-of-range)) | |
266 | (list-ref args 3) | |
267 | '()))) | |
268 | (run-hook before-backtrace-hook) | |
269 | (newline cep) | |
270 | (display "Backtrace:\n") | |
271 | (display-backtrace (fluid-ref the-last-stack) cep | |
272 | #f #f highlights) | |
273 | (newline cep) | |
274 | (run-hook after-backtrace-hook)))) | |
275 | (run-hook before-error-hook) | |
276 | (apply display-error (fluid-ref the-last-stack) cep args) | |
277 | (run-hook after-error-hook) | |
278 | (force-output cep) | |
279 | (throw 'abort key))) |