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