Commit | Line | Data |
---|---|---|
8fade76f MW |
1 | ;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner |
2 | ;; Added "full" support for Chicken, Gauche, Guile and SISC. | |
3 | ;; Alex Shinn, Copyright (c) 2005. | |
4 | ;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. | |
5 | ;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014. | |
341c6fdd LC |
6 | ;; |
7 | ;; Permission is hereby granted, free of charge, to any person | |
8 | ;; obtaining a copy of this software and associated documentation | |
9 | ;; files (the "Software"), to deal in the Software without | |
10 | ;; restriction, including without limitation the rights to use, copy, | |
11 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies | |
12 | ;; of the Software, and to permit persons to whom the Software is | |
13 | ;; furnished to do so, subject to the following conditions: | |
14 | ;; | |
15 | ;; The above copyright notice and this permission notice shall be | |
16 | ;; included in all copies or substantial portions of the Software. | |
17 | ;; | |
18 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
19 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
20 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND | |
21 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS | |
22 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN | |
23 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN | |
24 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | |
25 | ;; SOFTWARE. | |
26 | ||
27 | (cond-expand | |
28 | (chicken | |
29 | (require-extension syntax-case)) | |
8fade76f | 30 | (guile-2 |
fd96bc05 | 31 | (use-modules (srfi srfi-9) |
8fade76f MW |
32 | ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated |
33 | ;; with either Guile's native exceptions or R6RS exceptions. | |
34 | ;;(srfi srfi-34) (srfi srfi-35) | |
35 | (srfi srfi-39))) | |
36 | (guile | |
37 | (use-modules (ice-9 syncase) (srfi srfi-9) | |
341c6fdd LC |
38 | ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 |
39 | (srfi srfi-39))) | |
40 | (sisc | |
41 | (require-extension (srfi 9 34 35 39))) | |
42 | (kawa | |
43 | (module-compile-options warn-undefined-variable: #t | |
44 | warn-invoke-unknown-method: #t) | |
45 | (provide 'srfi-64) | |
46 | (provide 'testing) | |
47 | (require 'srfi-34) | |
48 | (require 'srfi-35)) | |
49 | (else () | |
50 | )) | |
51 | ||
52 | (cond-expand | |
53 | (kawa | |
54 | (define-syntax %test-export | |
55 | (syntax-rules () | |
56 | ((%test-export test-begin . other-names) | |
57 | (module-export %test-begin . other-names))))) | |
58 | (else | |
59 | (define-syntax %test-export | |
60 | (syntax-rules () | |
61 | ((%test-export . names) (if #f #f)))))) | |
62 | ||
63 | ;; List of exported names | |
64 | (%test-export | |
65 | test-begin ;; must be listed first, since in Kawa (at least) it is "magic". | |
66 | test-end test-assert test-eqv test-eq test-equal | |
67 | test-approximate test-assert test-error test-apply test-with-runner | |
68 | test-match-nth test-match-all test-match-any test-match-name | |
69 | test-skip test-expect-fail test-read-eval-string | |
8fade76f | 70 | test-runner-group-path test-group test-group-with-cleanup |
341c6fdd LC |
71 | test-result-ref test-result-set! test-result-clear test-result-remove |
72 | test-result-kind test-passed? | |
73 | test-log-to-file | |
74 | ; Misc test-runner functions | |
75 | test-runner? test-runner-reset test-runner-null | |
76 | test-runner-simple test-runner-current test-runner-factory test-runner-get | |
77 | test-runner-create test-runner-test-name | |
78 | ;; test-runner field setter and getter functions - see %test-record-define: | |
79 | test-runner-pass-count test-runner-pass-count! | |
80 | test-runner-fail-count test-runner-fail-count! | |
81 | test-runner-xpass-count test-runner-xpass-count! | |
82 | test-runner-xfail-count test-runner-xfail-count! | |
83 | test-runner-skip-count test-runner-skip-count! | |
84 | test-runner-group-stack test-runner-group-stack! | |
85 | test-runner-on-test-begin test-runner-on-test-begin! | |
86 | test-runner-on-test-end test-runner-on-test-end! | |
87 | test-runner-on-group-begin test-runner-on-group-begin! | |
88 | test-runner-on-group-end test-runner-on-group-end! | |
89 | test-runner-on-final test-runner-on-final! | |
90 | test-runner-on-bad-count test-runner-on-bad-count! | |
91 | test-runner-on-bad-end-name test-runner-on-bad-end-name! | |
92 | test-result-alist test-result-alist! | |
93 | test-runner-aux-value test-runner-aux-value! | |
94 | ;; default/simple call-back functions, used in default test-runner, | |
95 | ;; but can be called to construct more complex ones. | |
96 | test-on-group-begin-simple test-on-group-end-simple | |
97 | test-on-bad-count-simple test-on-bad-end-name-simple | |
98 | test-on-final-simple test-on-test-end-simple | |
99 | test-on-final-simple) | |
100 | ||
101 | (cond-expand | |
102 | (srfi-9 | |
103 | (define-syntax %test-record-define | |
104 | (syntax-rules () | |
105 | ((%test-record-define alloc runner? (name index setter getter) ...) | |
106 | (define-record-type test-runner | |
107 | (alloc) | |
108 | runner? | |
109 | (name setter getter) ...))))) | |
110 | (else | |
111 | (define %test-runner-cookie (list "test-runner")) | |
112 | (define-syntax %test-record-define | |
113 | (syntax-rules () | |
114 | ((%test-record-define alloc runner? (name index getter setter) ...) | |
115 | (begin | |
116 | (define (runner? obj) | |
117 | (and (vector? obj) | |
118 | (> (vector-length obj) 1) | |
119 | (eq (vector-ref obj 0) %test-runner-cookie))) | |
120 | (define (alloc) | |
8fade76f | 121 | (let ((runner (make-vector 23))) |
341c6fdd LC |
122 | (vector-set! runner 0 %test-runner-cookie) |
123 | runner)) | |
124 | (begin | |
125 | (define (getter runner) | |
126 | (vector-ref runner index)) ...) | |
127 | (begin | |
128 | (define (setter runner value) | |
129 | (vector-set! runner index value)) ...))))))) | |
130 | ||
131 | (%test-record-define | |
132 | %test-runner-alloc test-runner? | |
133 | ;; Cumulate count of all tests that have passed and were expected to. | |
134 | (pass-count 1 test-runner-pass-count test-runner-pass-count!) | |
135 | (fail-count 2 test-runner-fail-count test-runner-fail-count!) | |
136 | (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!) | |
137 | (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!) | |
138 | (skip-count 5 test-runner-skip-count test-runner-skip-count!) | |
139 | (skip-list 6 %test-runner-skip-list %test-runner-skip-list!) | |
140 | (fail-list 7 %test-runner-fail-list %test-runner-fail-list!) | |
141 | ;; Normally #t, except when in a test-apply. | |
142 | (run-list 8 %test-runner-run-list %test-runner-run-list!) | |
143 | (skip-save 9 %test-runner-skip-save %test-runner-skip-save!) | |
144 | (fail-save 10 %test-runner-fail-save %test-runner-fail-save!) | |
145 | (group-stack 11 test-runner-group-stack test-runner-group-stack!) | |
146 | (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!) | |
147 | (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!) | |
148 | ;; Call-back when entering a group. Takes (runner suite-name count). | |
149 | (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!) | |
150 | ;; Call-back when leaving a group. | |
151 | (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!) | |
152 | ;; Call-back when leaving the outermost group. | |
153 | (on-final 16 test-runner-on-final test-runner-on-final!) | |
154 | ;; Call-back when expected number of tests was wrong. | |
155 | (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!) | |
156 | ;; Call-back when name in test=end doesn't match test-begin. | |
157 | (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!) | |
158 | ;; Cumulate count of all tests that have been done. | |
159 | (total-count 19 %test-runner-total-count %test-runner-total-count!) | |
160 | ;; Stack (list) of (count-at-start . expected-count): | |
161 | (count-list 20 %test-runner-count-list %test-runner-count-list!) | |
162 | (result-alist 21 test-result-alist test-result-alist!) | |
163 | ;; Field can be used by test-runner for any purpose. | |
164 | ;; test-runner-simple uses it for a log file. | |
165 | (aux-value 22 test-runner-aux-value test-runner-aux-value!) | |
166 | ) | |
167 | ||
168 | (define (test-runner-reset runner) | |
8fade76f MW |
169 | (test-result-alist! runner '()) |
170 | (test-runner-pass-count! runner 0) | |
171 | (test-runner-fail-count! runner 0) | |
172 | (test-runner-xpass-count! runner 0) | |
173 | (test-runner-xfail-count! runner 0) | |
174 | (test-runner-skip-count! runner 0) | |
175 | (%test-runner-total-count! runner 0) | |
176 | (%test-runner-count-list! runner '()) | |
177 | (%test-runner-run-list! runner #t) | |
178 | (%test-runner-skip-list! runner '()) | |
179 | (%test-runner-fail-list! runner '()) | |
180 | (%test-runner-skip-save! runner '()) | |
181 | (%test-runner-fail-save! runner '()) | |
182 | (test-runner-group-stack! runner '())) | |
341c6fdd LC |
183 | |
184 | (define (test-runner-group-path runner) | |
185 | (reverse (test-runner-group-stack runner))) | |
186 | ||
187 | (define (%test-null-callback runner) #f) | |
188 | ||
189 | (define (test-runner-null) | |
190 | (let ((runner (%test-runner-alloc))) | |
191 | (test-runner-reset runner) | |
192 | (test-runner-on-group-begin! runner (lambda (runner name count) #f)) | |
193 | (test-runner-on-group-end! runner %test-null-callback) | |
194 | (test-runner-on-final! runner %test-null-callback) | |
195 | (test-runner-on-test-begin! runner %test-null-callback) | |
196 | (test-runner-on-test-end! runner %test-null-callback) | |
197 | (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) | |
198 | (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) | |
199 | runner)) | |
200 | ||
201 | ;; Not part of the specification. FIXME | |
202 | ;; Controls whether a log file is generated. | |
203 | (define test-log-to-file #t) | |
204 | ||
205 | (define (test-runner-simple) | |
206 | (let ((runner (%test-runner-alloc))) | |
207 | (test-runner-reset runner) | |
208 | (test-runner-on-group-begin! runner test-on-group-begin-simple) | |
209 | (test-runner-on-group-end! runner test-on-group-end-simple) | |
210 | (test-runner-on-final! runner test-on-final-simple) | |
211 | (test-runner-on-test-begin! runner test-on-test-begin-simple) | |
212 | (test-runner-on-test-end! runner test-on-test-end-simple) | |
213 | (test-runner-on-bad-count! runner test-on-bad-count-simple) | |
214 | (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) | |
215 | runner)) | |
216 | ||
217 | (cond-expand | |
218 | (srfi-39 | |
219 | (define test-runner-current (make-parameter #f)) | |
220 | (define test-runner-factory (make-parameter test-runner-simple))) | |
221 | (else | |
222 | (define %test-runner-current #f) | |
223 | (define-syntax test-runner-current | |
224 | (syntax-rules () | |
225 | ((test-runner-current) | |
226 | %test-runner-current) | |
227 | ((test-runner-current runner) | |
228 | (set! %test-runner-current runner)))) | |
229 | (define %test-runner-factory test-runner-simple) | |
230 | (define-syntax test-runner-factory | |
231 | (syntax-rules () | |
232 | ((test-runner-factory) | |
233 | %test-runner-factory) | |
234 | ((test-runner-factory runner) | |
235 | (set! %test-runner-factory runner)))))) | |
236 | ||
237 | ;; A safer wrapper to test-runner-current. | |
238 | (define (test-runner-get) | |
239 | (let ((r (test-runner-current))) | |
240 | (if (not r) | |
241 | (cond-expand | |
242 | (srfi-23 (error "test-runner not initialized - test-begin missing?")) | |
243 | (else #t))) | |
244 | r)) | |
245 | ||
8fade76f | 246 | (define (%test-specifier-matches spec runner) |
341c6fdd LC |
247 | (spec runner)) |
248 | ||
249 | (define (test-runner-create) | |
250 | ((test-runner-factory))) | |
251 | ||
252 | (define (%test-any-specifier-matches list runner) | |
253 | (let ((result #f)) | |
254 | (let loop ((l list)) | |
255 | (cond ((null? l) result) | |
256 | (else | |
8fade76f | 257 | (if (%test-specifier-matches (car l) runner) |
341c6fdd LC |
258 | (set! result #t)) |
259 | (loop (cdr l))))))) | |
260 | ||
261 | ;; Returns #f, #t, or 'xfail. | |
262 | (define (%test-should-execute runner) | |
263 | (let ((run (%test-runner-run-list runner))) | |
264 | (cond ((or | |
265 | (not (or (eqv? run #t) | |
266 | (%test-any-specifier-matches run runner))) | |
267 | (%test-any-specifier-matches | |
268 | (%test-runner-skip-list runner) | |
269 | runner)) | |
270 | (test-result-set! runner 'result-kind 'skip) | |
271 | #f) | |
272 | ((%test-any-specifier-matches | |
273 | (%test-runner-fail-list runner) | |
274 | runner) | |
275 | (test-result-set! runner 'result-kind 'xfail) | |
276 | 'xfail) | |
277 | (else #t)))) | |
278 | ||
279 | (define (%test-begin suite-name count) | |
280 | (if (not (test-runner-current)) | |
281 | (test-runner-current (test-runner-create))) | |
282 | (let ((runner (test-runner-current))) | |
283 | ((test-runner-on-group-begin runner) runner suite-name count) | |
284 | (%test-runner-skip-save! runner | |
285 | (cons (%test-runner-skip-list runner) | |
286 | (%test-runner-skip-save runner))) | |
287 | (%test-runner-fail-save! runner | |
288 | (cons (%test-runner-fail-list runner) | |
289 | (%test-runner-fail-save runner))) | |
290 | (%test-runner-count-list! runner | |
291 | (cons (cons (%test-runner-total-count runner) | |
292 | count) | |
293 | (%test-runner-count-list runner))) | |
294 | (test-runner-group-stack! runner (cons suite-name | |
295 | (test-runner-group-stack runner))))) | |
296 | (cond-expand | |
297 | (kawa | |
298 | ;; Kawa has test-begin built in, implemented as: | |
299 | ;; (begin | |
300 | ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) | |
301 | ;; (%test-begin suite-name [count])) | |
302 | ;; This puts test-begin but only test-begin in the default environment., | |
303 | ;; which makes normal test suites loadable without non-portable commands. | |
304 | ) | |
305 | (else | |
306 | (define-syntax test-begin | |
307 | (syntax-rules () | |
308 | ((test-begin suite-name) | |
309 | (%test-begin suite-name #f)) | |
310 | ((test-begin suite-name count) | |
311 | (%test-begin suite-name count)))))) | |
312 | ||
313 | (define (test-on-group-begin-simple runner suite-name count) | |
314 | (if (null? (test-runner-group-stack runner)) | |
315 | (begin | |
316 | (display "%%%% Starting test ") | |
317 | (display suite-name) | |
318 | (if test-log-to-file | |
319 | (let* ((log-file-name | |
320 | (if (string? test-log-to-file) test-log-to-file | |
321 | (string-append suite-name ".log"))) | |
322 | (log-file | |
323 | (cond-expand (mzscheme | |
324 | (open-output-file log-file-name 'truncate/replace)) | |
341c6fdd LC |
325 | (else (open-output-file log-file-name))))) |
326 | (display "%%%% Starting test " log-file) | |
327 | (display suite-name log-file) | |
328 | (newline log-file) | |
329 | (test-runner-aux-value! runner log-file) | |
330 | (display " (Writing full log to \"") | |
331 | (display log-file-name) | |
332 | (display "\")"))) | |
333 | (newline))) | |
334 | (let ((log (test-runner-aux-value runner))) | |
335 | (if (output-port? log) | |
336 | (begin | |
337 | (display "Group begin: " log) | |
338 | (display suite-name log) | |
339 | (newline log)))) | |
340 | #f) | |
341 | ||
342 | (define (test-on-group-end-simple runner) | |
343 | (let ((log (test-runner-aux-value runner))) | |
344 | (if (output-port? log) | |
345 | (begin | |
346 | (display "Group end: " log) | |
347 | (display (car (test-runner-group-stack runner)) log) | |
348 | (newline log)))) | |
349 | #f) | |
350 | ||
351 | (define (%test-on-bad-count-write runner count expected-count port) | |
352 | (display "*** Total number of tests was " port) | |
353 | (display count port) | |
354 | (display " but should be " port) | |
355 | (display expected-count port) | |
356 | (display ". ***" port) | |
357 | (newline port) | |
358 | (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) | |
359 | (newline port)) | |
360 | ||
361 | (define (test-on-bad-count-simple runner count expected-count) | |
362 | (%test-on-bad-count-write runner count expected-count (current-output-port)) | |
363 | (let ((log (test-runner-aux-value runner))) | |
364 | (if (output-port? log) | |
365 | (%test-on-bad-count-write runner count expected-count log)))) | |
366 | ||
367 | (define (test-on-bad-end-name-simple runner begin-name end-name) | |
368 | (let ((msg (string-append (%test-format-line runner) "test-end " begin-name | |
369 | " does not match test-begin " end-name))) | |
370 | (cond-expand | |
371 | (srfi-23 (error msg)) | |
372 | (else (display msg) (newline))))) | |
373 | ||
374 | ||
375 | (define (%test-final-report1 value label port) | |
376 | (if (> value 0) | |
377 | (begin | |
378 | (display label port) | |
379 | (display value port) | |
380 | (newline port)))) | |
381 | ||
382 | (define (%test-final-report-simple runner port) | |
383 | (%test-final-report1 (test-runner-pass-count runner) | |
384 | "# of expected passes " port) | |
385 | (%test-final-report1 (test-runner-xfail-count runner) | |
386 | "# of expected failures " port) | |
387 | (%test-final-report1 (test-runner-xpass-count runner) | |
388 | "# of unexpected successes " port) | |
389 | (%test-final-report1 (test-runner-fail-count runner) | |
390 | "# of unexpected failures " port) | |
391 | (%test-final-report1 (test-runner-skip-count runner) | |
392 | "# of skipped tests " port)) | |
393 | ||
394 | (define (test-on-final-simple runner) | |
395 | (%test-final-report-simple runner (current-output-port)) | |
396 | (let ((log (test-runner-aux-value runner))) | |
397 | (if (output-port? log) | |
398 | (%test-final-report-simple runner log)))) | |
399 | ||
400 | (define (%test-format-line runner) | |
401 | (let* ((line-info (test-result-alist runner)) | |
402 | (source-file (assq 'source-file line-info)) | |
403 | (source-line (assq 'source-line line-info)) | |
404 | (file (if source-file (cdr source-file) ""))) | |
405 | (if source-line | |
406 | (string-append file ":" | |
407 | (number->string (cdr source-line)) ": ") | |
408 | ""))) | |
409 | ||
410 | (define (%test-end suite-name line-info) | |
411 | (let* ((r (test-runner-get)) | |
412 | (groups (test-runner-group-stack r)) | |
413 | (line (%test-format-line r))) | |
414 | (test-result-alist! r line-info) | |
415 | (if (null? groups) | |
416 | (let ((msg (string-append line "test-end not in a group"))) | |
417 | (cond-expand | |
418 | (srfi-23 (error msg)) | |
419 | (else (display msg) (newline))))) | |
420 | (if (and suite-name (not (equal? suite-name (car groups)))) | |
421 | ((test-runner-on-bad-end-name r) r suite-name (car groups))) | |
422 | (let* ((count-list (%test-runner-count-list r)) | |
423 | (expected-count (cdar count-list)) | |
424 | (saved-count (caar count-list)) | |
425 | (group-count (- (%test-runner-total-count r) saved-count))) | |
426 | (if (and expected-count | |
427 | (not (= expected-count group-count))) | |
428 | ((test-runner-on-bad-count r) r group-count expected-count)) | |
429 | ((test-runner-on-group-end r) r) | |
430 | (test-runner-group-stack! r (cdr (test-runner-group-stack r))) | |
431 | (%test-runner-skip-list! r (car (%test-runner-skip-save r))) | |
432 | (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) | |
433 | (%test-runner-fail-list! r (car (%test-runner-fail-save r))) | |
434 | (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) | |
435 | (%test-runner-count-list! r (cdr count-list)) | |
436 | (if (null? (test-runner-group-stack r)) | |
437 | ((test-runner-on-final r) r))))) | |
438 | ||
439 | (define-syntax test-group | |
440 | (syntax-rules () | |
441 | ((test-group suite-name . body) | |
442 | (let ((r (test-runner-current))) | |
443 | ;; Ideally should also set line-number, if available. | |
444 | (test-result-alist! r (list (cons 'test-name suite-name))) | |
445 | (if (%test-should-execute r) | |
446 | (dynamic-wind | |
447 | (lambda () (test-begin suite-name)) | |
448 | (lambda () . body) | |
449 | (lambda () (test-end suite-name)))))))) | |
450 | ||
451 | (define-syntax test-group-with-cleanup | |
452 | (syntax-rules () | |
453 | ((test-group-with-cleanup suite-name form cleanup-form) | |
454 | (test-group suite-name | |
455 | (dynamic-wind | |
456 | (lambda () #f) | |
457 | (lambda () form) | |
458 | (lambda () cleanup-form)))) | |
459 | ((test-group-with-cleanup suite-name cleanup-form) | |
460 | (test-group-with-cleanup suite-name #f cleanup-form)) | |
461 | ((test-group-with-cleanup suite-name form1 form2 form3 . rest) | |
462 | (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) | |
463 | ||
464 | (define (test-on-test-begin-simple runner) | |
465 | (let ((log (test-runner-aux-value runner))) | |
466 | (if (output-port? log) | |
467 | (let* ((results (test-result-alist runner)) | |
468 | (source-file (assq 'source-file results)) | |
469 | (source-line (assq 'source-line results)) | |
470 | (source-form (assq 'source-form results)) | |
471 | (test-name (assq 'test-name results))) | |
472 | (display "Test begin:" log) | |
473 | (newline log) | |
474 | (if test-name (%test-write-result1 test-name log)) | |
475 | (if source-file (%test-write-result1 source-file log)) | |
476 | (if source-line (%test-write-result1 source-line log)) | |
8fade76f | 477 | (if source-form (%test-write-result1 source-form log)))))) |
341c6fdd LC |
478 | |
479 | (define-syntax test-result-ref | |
480 | (syntax-rules () | |
481 | ((test-result-ref runner pname) | |
482 | (test-result-ref runner pname #f)) | |
483 | ((test-result-ref runner pname default) | |
484 | (let ((p (assq pname (test-result-alist runner)))) | |
485 | (if p (cdr p) default))))) | |
486 | ||
487 | (define (test-on-test-end-simple runner) | |
488 | (let ((log (test-runner-aux-value runner)) | |
489 | (kind (test-result-ref runner 'result-kind))) | |
490 | (if (memq kind '(fail xpass)) | |
491 | (let* ((results (test-result-alist runner)) | |
492 | (source-file (assq 'source-file results)) | |
493 | (source-line (assq 'source-line results)) | |
494 | (test-name (assq 'test-name results))) | |
495 | (if (or source-file source-line) | |
496 | (begin | |
497 | (if source-file (display (cdr source-file))) | |
498 | (display ":") | |
499 | (if source-line (display (cdr source-line))) | |
500 | (display ": "))) | |
501 | (display (if (eq? kind 'xpass) "XPASS" "FAIL")) | |
502 | (if test-name | |
503 | (begin | |
504 | (display " ") | |
505 | (display (cdr test-name)))) | |
506 | (newline))) | |
507 | (if (output-port? log) | |
508 | (begin | |
509 | (display "Test end:" log) | |
510 | (newline log) | |
511 | (let loop ((list (test-result-alist runner))) | |
512 | (if (pair? list) | |
513 | (let ((pair (car list))) | |
514 | ;; Write out properties not written out by on-test-begin. | |
515 | (if (not (memq (car pair) | |
516 | '(test-name source-file source-line source-form))) | |
517 | (%test-write-result1 pair log)) | |
518 | (loop (cdr list))))))))) | |
519 | ||
520 | (define (%test-write-result1 pair port) | |
521 | (display " " port) | |
522 | (display (car pair) port) | |
523 | (display ": " port) | |
524 | (write (cdr pair) port) | |
525 | (newline port)) | |
526 | ||
527 | (define (test-result-set! runner pname value) | |
528 | (let* ((alist (test-result-alist runner)) | |
529 | (p (assq pname alist))) | |
530 | (if p | |
531 | (set-cdr! p value) | |
532 | (test-result-alist! runner (cons (cons pname value) alist))))) | |
533 | ||
534 | (define (test-result-clear runner) | |
535 | (test-result-alist! runner '())) | |
536 | ||
537 | (define (test-result-remove runner pname) | |
538 | (let* ((alist (test-result-alist runner)) | |
539 | (p (assq pname alist))) | |
540 | (if p | |
541 | (test-result-alist! runner | |
542 | (let loop ((r alist)) | |
543 | (if (eq? r p) (cdr r) | |
544 | (cons (car r) (loop (cdr r))))))))) | |
545 | ||
546 | (define (test-result-kind . rest) | |
547 | (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) | |
548 | (test-result-ref runner 'result-kind))) | |
549 | ||
550 | (define (test-passed? . rest) | |
551 | (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) | |
552 | (memq (test-result-ref runner 'result-kind) '(pass xpass)))) | |
553 | ||
554 | (define (%test-report-result) | |
555 | (let* ((r (test-runner-get)) | |
556 | (result-kind (test-result-kind r))) | |
557 | (case result-kind | |
558 | ((pass) | |
559 | (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) | |
560 | ((fail) | |
561 | (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) | |
562 | ((xpass) | |
563 | (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) | |
564 | ((xfail) | |
565 | (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) | |
566 | (else | |
567 | (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) | |
568 | (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) | |
569 | ((test-runner-on-test-end r) r))) | |
570 | ||
571 | (cond-expand | |
572 | (guile | |
573 | (define-syntax %test-evaluate-with-catch | |
574 | (syntax-rules () | |
575 | ((%test-evaluate-with-catch test-expression) | |
576 | (catch #t | |
577 | (lambda () test-expression) | |
341c6fdd | 578 | (lambda (key . args) |
8fade76f MW |
579 | (test-result-set! (test-runner-current) 'actual-error |
580 | (cons key args)) | |
581 | #f)))))) | |
341c6fdd LC |
582 | (kawa |
583 | (define-syntax %test-evaluate-with-catch | |
584 | (syntax-rules () | |
585 | ((%test-evaluate-with-catch test-expression) | |
586 | (try-catch test-expression | |
587 | (ex <java.lang.Throwable> | |
588 | (test-result-set! (test-runner-current) 'actual-error ex) | |
589 | #f)))))) | |
590 | (srfi-34 | |
591 | (define-syntax %test-evaluate-with-catch | |
592 | (syntax-rules () | |
593 | ((%test-evaluate-with-catch test-expression) | |
594 | (guard (err (else #f)) test-expression))))) | |
595 | (chicken | |
596 | (define-syntax %test-evaluate-with-catch | |
597 | (syntax-rules () | |
598 | ((%test-evaluate-with-catch test-expression) | |
599 | (condition-case test-expression (ex () #f)))))) | |
600 | (else | |
601 | (define-syntax %test-evaluate-with-catch | |
602 | (syntax-rules () | |
603 | ((%test-evaluate-with-catch test-expression) | |
604 | test-expression))))) | |
605 | ||
606 | (cond-expand | |
607 | ((or kawa mzscheme) | |
608 | (cond-expand | |
609 | (mzscheme | |
610 | (define-for-syntax (%test-syntax-file form) | |
611 | (let ((source (syntax-source form))) | |
612 | (cond ((string? source) file) | |
613 | ((path? source) (path->string source)) | |
614 | (else #f))))) | |
615 | (kawa | |
616 | (define (%test-syntax-file form) | |
617 | (syntax-source form)))) | |
8fade76f | 618 | (define (%test-source-line2 form) |
341c6fdd LC |
619 | (let* ((line (syntax-line form)) |
620 | (file (%test-syntax-file form)) | |
621 | (line-pair (if line (list (cons 'source-line line)) '()))) | |
622 | (cons (cons 'source-form (syntax-object->datum form)) | |
623 | (if file (cons (cons 'source-file file) line-pair) line-pair))))) | |
8fade76f MW |
624 | (guile-2 |
625 | (define (%test-source-line2 form) | |
626 | (let* ((src-props (syntax-source form)) | |
627 | (file (and src-props (assq-ref src-props 'filename))) | |
628 | (line (and src-props (assq-ref src-props 'line))) | |
629 | (file-alist (if file | |
630 | `((source-file . ,file)) | |
631 | '())) | |
632 | (line-alist (if line | |
633 | `((source-line . ,(+ line 1))) | |
634 | '()))) | |
635 | (datum->syntax (syntax here) | |
636 | `((source-form . ,(syntax->datum form)) | |
637 | ,@file-alist | |
638 | ,@line-alist))))) | |
341c6fdd LC |
639 | (else |
640 | (define (%test-source-line2 form) | |
641 | '()))) | |
642 | ||
643 | (define (%test-on-test-begin r) | |
644 | (%test-should-execute r) | |
645 | ((test-runner-on-test-begin r) r) | |
646 | (not (eq? 'skip (test-result-ref r 'result-kind)))) | |
647 | ||
648 | (define (%test-on-test-end r result) | |
649 | (test-result-set! r 'result-kind | |
650 | (if (eq? (test-result-ref r 'result-kind) 'xfail) | |
651 | (if result 'xpass 'xfail) | |
652 | (if result 'pass 'fail)))) | |
653 | ||
654 | (define (test-runner-test-name runner) | |
655 | (test-result-ref runner 'test-name "")) | |
656 | ||
657 | (define-syntax %test-comp2body | |
658 | (syntax-rules () | |
659 | ((%test-comp2body r comp expected expr) | |
660 | (let () | |
661 | (if (%test-on-test-begin r) | |
662 | (let ((exp expected)) | |
663 | (test-result-set! r 'expected-value exp) | |
664 | (let ((res (%test-evaluate-with-catch expr))) | |
665 | (test-result-set! r 'actual-value res) | |
666 | (%test-on-test-end r (comp exp res))))) | |
667 | (%test-report-result))))) | |
668 | ||
8fade76f | 669 | (define (%test-approximate= error) |
341c6fdd | 670 | (lambda (value expected) |
8fade76f MW |
671 | (let ((rval (real-part value)) |
672 | (ival (imag-part value)) | |
673 | (rexp (real-part expected)) | |
674 | (iexp (imag-part expected))) | |
675 | (and (>= rval (- rexp error)) | |
676 | (>= ival (- iexp error)) | |
677 | (<= rval (+ rexp error)) | |
678 | (<= ival (+ iexp error)))))) | |
341c6fdd LC |
679 | |
680 | (define-syntax %test-comp1body | |
681 | (syntax-rules () | |
682 | ((%test-comp1body r expr) | |
683 | (let () | |
684 | (if (%test-on-test-begin r) | |
685 | (let () | |
686 | (let ((res (%test-evaluate-with-catch expr))) | |
687 | (test-result-set! r 'actual-value res) | |
688 | (%test-on-test-end r res)))) | |
689 | (%test-report-result))))) | |
690 | ||
691 | (cond-expand | |
8fade76f | 692 | ((or kawa mzscheme guile-2) |
341c6fdd LC |
693 | ;; Should be made to work for any Scheme with syntax-case |
694 | ;; However, I haven't gotten the quoting working. FIXME. | |
695 | (define-syntax test-end | |
696 | (lambda (x) | |
8fade76f | 697 | (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () |
341c6fdd LC |
698 | (((mac suite-name) line) |
699 | (syntax | |
700 | (%test-end suite-name line))) | |
701 | (((mac) line) | |
702 | (syntax | |
703 | (%test-end #f line)))))) | |
704 | (define-syntax test-assert | |
705 | (lambda (x) | |
8fade76f | 706 | (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () |
341c6fdd LC |
707 | (((mac tname expr) line) |
708 | (syntax | |
709 | (let* ((r (test-runner-get)) | |
710 | (name tname)) | |
711 | (test-result-alist! r (cons (cons 'test-name tname) line)) | |
712 | (%test-comp1body r expr)))) | |
713 | (((mac expr) line) | |
714 | (syntax | |
715 | (let* ((r (test-runner-get))) | |
716 | (test-result-alist! r line) | |
717 | (%test-comp1body r expr))))))) | |
8fade76f MW |
718 | (define (%test-comp2 comp x) |
719 | (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) () | |
341c6fdd LC |
720 | (((mac tname expected expr) line comp) |
721 | (syntax | |
722 | (let* ((r (test-runner-get)) | |
723 | (name tname)) | |
724 | (test-result-alist! r (cons (cons 'test-name tname) line)) | |
725 | (%test-comp2body r comp expected expr)))) | |
726 | (((mac expected expr) line comp) | |
727 | (syntax | |
728 | (let* ((r (test-runner-get))) | |
729 | (test-result-alist! r line) | |
730 | (%test-comp2body r comp expected expr)))))) | |
731 | (define-syntax test-eqv | |
732 | (lambda (x) (%test-comp2 (syntax eqv?) x))) | |
733 | (define-syntax test-eq | |
734 | (lambda (x) (%test-comp2 (syntax eq?) x))) | |
735 | (define-syntax test-equal | |
736 | (lambda (x) (%test-comp2 (syntax equal?) x))) | |
737 | (define-syntax test-approximate ;; FIXME - needed for non-Kawa | |
738 | (lambda (x) | |
8fade76f | 739 | (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () |
341c6fdd LC |
740 | (((mac tname expected expr error) line) |
741 | (syntax | |
742 | (let* ((r (test-runner-get)) | |
743 | (name tname)) | |
744 | (test-result-alist! r (cons (cons 'test-name tname) line)) | |
8fade76f | 745 | (%test-comp2body r (%test-approximate= error) expected expr)))) |
341c6fdd LC |
746 | (((mac expected expr error) line) |
747 | (syntax | |
748 | (let* ((r (test-runner-get))) | |
749 | (test-result-alist! r line) | |
8fade76f | 750 | (%test-comp2body r (%test-approximate= error) expected expr)))))))) |
341c6fdd LC |
751 | (else |
752 | (define-syntax test-end | |
753 | (syntax-rules () | |
754 | ((test-end) | |
755 | (%test-end #f '())) | |
756 | ((test-end suite-name) | |
757 | (%test-end suite-name '())))) | |
758 | (define-syntax test-assert | |
759 | (syntax-rules () | |
760 | ((test-assert tname test-expression) | |
761 | (let* ((r (test-runner-get)) | |
762 | (name tname)) | |
763 | (test-result-alist! r '((test-name . tname))) | |
764 | (%test-comp1body r test-expression))) | |
765 | ((test-assert test-expression) | |
766 | (let* ((r (test-runner-get))) | |
767 | (test-result-alist! r '()) | |
768 | (%test-comp1body r test-expression))))) | |
769 | (define-syntax %test-comp2 | |
770 | (syntax-rules () | |
771 | ((%test-comp2 comp tname expected expr) | |
772 | (let* ((r (test-runner-get)) | |
773 | (name tname)) | |
774 | (test-result-alist! r (list (cons 'test-name tname))) | |
775 | (%test-comp2body r comp expected expr))) | |
776 | ((%test-comp2 comp expected expr) | |
777 | (let* ((r (test-runner-get))) | |
778 | (test-result-alist! r '()) | |
779 | (%test-comp2body r comp expected expr))))) | |
780 | (define-syntax test-equal | |
781 | (syntax-rules () | |
782 | ((test-equal . rest) | |
783 | (%test-comp2 equal? . rest)))) | |
784 | (define-syntax test-eqv | |
785 | (syntax-rules () | |
786 | ((test-eqv . rest) | |
787 | (%test-comp2 eqv? . rest)))) | |
788 | (define-syntax test-eq | |
789 | (syntax-rules () | |
790 | ((test-eq . rest) | |
791 | (%test-comp2 eq? . rest)))) | |
792 | (define-syntax test-approximate | |
793 | (syntax-rules () | |
794 | ((test-approximate tname expected expr error) | |
8fade76f | 795 | (%test-comp2 (%test-approximate= error) tname expected expr)) |
341c6fdd | 796 | ((test-approximate expected expr error) |
8fade76f | 797 | (%test-comp2 (%test-approximate= error) expected expr)))))) |
341c6fdd LC |
798 | |
799 | (cond-expand | |
800 | (guile | |
801 | (define-syntax %test-error | |
802 | (syntax-rules () | |
803 | ((%test-error r etype expr) | |
8fade76f MW |
804 | (cond ((%test-on-test-begin r) |
805 | (let ((et etype)) | |
806 | (test-result-set! r 'expected-error et) | |
807 | (%test-on-test-end r | |
808 | (catch #t | |
809 | (lambda () | |
810 | (test-result-set! r 'actual-value expr) | |
811 | #f) | |
812 | (lambda (key . args) | |
813 | ;; TODO: decide how to specify expected | |
814 | ;; error types for Guile. | |
815 | (test-result-set! r 'actual-error | |
816 | (cons key args)) | |
817 | #t))) | |
818 | (%test-report-result)))))))) | |
341c6fdd LC |
819 | (mzscheme |
820 | (define-syntax %test-error | |
821 | (syntax-rules () | |
822 | ((%test-error r etype expr) | |
823 | (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t))) | |
824 | (let () | |
825 | (test-result-set! r 'actual-value expr) | |
826 | #f))))))) | |
827 | (chicken | |
828 | (define-syntax %test-error | |
829 | (syntax-rules () | |
830 | ((%test-error r etype expr) | |
831 | (%test-comp1body r (condition-case expr (ex () #t))))))) | |
832 | (kawa | |
833 | (define-syntax %test-error | |
834 | (syntax-rules () | |
8fade76f MW |
835 | ((%test-error r #t expr) |
836 | (cond ((%test-on-test-begin r) | |
837 | (test-result-set! r 'expected-error #t) | |
838 | (%test-on-test-end r | |
839 | (try-catch | |
840 | (let () | |
841 | (test-result-set! r 'actual-value expr) | |
842 | #f) | |
843 | (ex <java.lang.Throwable> | |
844 | (test-result-set! r 'actual-error ex) | |
845 | #t))) | |
846 | (%test-report-result)))) | |
341c6fdd | 847 | ((%test-error r etype expr) |
8fade76f MW |
848 | (if (%test-on-test-begin r) |
849 | (let ((et etype)) | |
850 | (test-result-set! r 'expected-error et) | |
851 | (%test-on-test-end r | |
852 | (try-catch | |
853 | (let () | |
854 | (test-result-set! r 'actual-value expr) | |
855 | #f) | |
856 | (ex <java.lang.Throwable> | |
857 | (test-result-set! r 'actual-error ex) | |
858 | (cond ((and (instance? et <gnu.bytecode.ClassType>) | |
859 | (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>)) | |
860 | (instance? ex et)) | |
861 | (else #t))))) | |
862 | (%test-report-result))))))) | |
341c6fdd LC |
863 | ((and srfi-34 srfi-35) |
864 | (define-syntax %test-error | |
865 | (syntax-rules () | |
866 | ((%test-error r etype expr) | |
867 | (%test-comp1body r (guard (ex ((condition-type? etype) | |
868 | (and (condition? ex) (condition-has-type? ex etype))) | |
869 | ((procedure? etype) | |
870 | (etype ex)) | |
8fade76f | 871 | ((equal? etype #t) |
341c6fdd LC |
872 | #t) |
873 | (else #t)) | |
8fade76f | 874 | expr #f)))))) |
341c6fdd LC |
875 | (srfi-34 |
876 | (define-syntax %test-error | |
877 | (syntax-rules () | |
878 | ((%test-error r etype expr) | |
8fade76f | 879 | (%test-comp1body r (guard (ex (else #t)) expr #f)))))) |
341c6fdd LC |
880 | (else |
881 | (define-syntax %test-error | |
882 | (syntax-rules () | |
883 | ((%test-error r etype expr) | |
884 | (begin | |
885 | ((test-runner-on-test-begin r) r) | |
886 | (test-result-set! r 'result-kind 'skip) | |
887 | (%test-report-result))))))) | |
888 | ||
889 | (cond-expand | |
8fade76f | 890 | ((or kawa mzscheme guile-2) |
341c6fdd LC |
891 | |
892 | (define-syntax test-error | |
893 | (lambda (x) | |
8fade76f | 894 | (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () |
341c6fdd LC |
895 | (((mac tname etype expr) line) |
896 | (syntax | |
897 | (let* ((r (test-runner-get)) | |
898 | (name tname)) | |
899 | (test-result-alist! r (cons (cons 'test-name tname) line)) | |
900 | (%test-error r etype expr)))) | |
901 | (((mac etype expr) line) | |
902 | (syntax | |
903 | (let* ((r (test-runner-get))) | |
904 | (test-result-alist! r line) | |
905 | (%test-error r etype expr)))) | |
906 | (((mac expr) line) | |
907 | (syntax | |
908 | (let* ((r (test-runner-get))) | |
909 | (test-result-alist! r line) | |
910 | (%test-error r #t expr)))))))) | |
911 | (else | |
912 | (define-syntax test-error | |
913 | (syntax-rules () | |
914 | ((test-error name etype expr) | |
8fade76f MW |
915 | (let ((r (test-runner-get))) |
916 | (test-result-alist! r `((test-name . ,name))) | |
917 | (%test-error r etype expr))) | |
341c6fdd | 918 | ((test-error etype expr) |
8fade76f MW |
919 | (let ((r (test-runner-get))) |
920 | (test-result-alist! r '()) | |
921 | (%test-error r etype expr))) | |
341c6fdd | 922 | ((test-error expr) |
8fade76f MW |
923 | (let ((r (test-runner-get))) |
924 | (test-result-alist! r '()) | |
925 | (%test-error r #t expr))))))) | |
341c6fdd LC |
926 | |
927 | (define (test-apply first . rest) | |
928 | (if (test-runner? first) | |
929 | (test-with-runner first (apply test-apply rest)) | |
930 | (let ((r (test-runner-current))) | |
931 | (if r | |
932 | (let ((run-list (%test-runner-run-list r))) | |
933 | (cond ((null? rest) | |
8fade76f | 934 | (%test-runner-run-list! r (reverse run-list)) |
341c6fdd LC |
935 | (first)) ;; actually apply procedure thunk |
936 | (else | |
937 | (%test-runner-run-list! | |
938 | r | |
939 | (if (eq? run-list #t) (list first) (cons first run-list))) | |
940 | (apply test-apply rest) | |
941 | (%test-runner-run-list! r run-list)))) | |
942 | (let ((r (test-runner-create))) | |
943 | (test-with-runner r (apply test-apply first rest)) | |
944 | ((test-runner-on-final r) r)))))) | |
945 | ||
946 | (define-syntax test-with-runner | |
947 | (syntax-rules () | |
948 | ((test-with-runner runner form ...) | |
949 | (let ((saved-runner (test-runner-current))) | |
950 | (dynamic-wind | |
951 | (lambda () (test-runner-current runner)) | |
952 | (lambda () form ...) | |
953 | (lambda () (test-runner-current saved-runner))))))) | |
954 | ||
955 | ;;; Predicates | |
956 | ||
957 | (define (%test-match-nth n count) | |
958 | (let ((i 0)) | |
959 | (lambda (runner) | |
960 | (set! i (+ i 1)) | |
961 | (and (>= i n) (< i (+ n count)))))) | |
962 | ||
963 | (define-syntax test-match-nth | |
964 | (syntax-rules () | |
965 | ((test-match-nth n) | |
966 | (test-match-nth n 1)) | |
967 | ((test-match-nth n count) | |
968 | (%test-match-nth n count)))) | |
969 | ||
970 | (define (%test-match-all . pred-list) | |
971 | (lambda (runner) | |
972 | (let ((result #t)) | |
973 | (let loop ((l pred-list)) | |
974 | (if (null? l) | |
975 | result | |
976 | (begin | |
977 | (if (not ((car l) runner)) | |
978 | (set! result #f)) | |
979 | (loop (cdr l)))))))) | |
980 | ||
981 | (define-syntax test-match-all | |
982 | (syntax-rules () | |
983 | ((test-match-all pred ...) | |
984 | (%test-match-all (%test-as-specifier pred) ...)))) | |
985 | ||
986 | (define (%test-match-any . pred-list) | |
987 | (lambda (runner) | |
988 | (let ((result #f)) | |
989 | (let loop ((l pred-list)) | |
990 | (if (null? l) | |
991 | result | |
992 | (begin | |
993 | (if ((car l) runner) | |
994 | (set! result #t)) | |
995 | (loop (cdr l)))))))) | |
996 | ||
997 | (define-syntax test-match-any | |
998 | (syntax-rules () | |
999 | ((test-match-any pred ...) | |
1000 | (%test-match-any (%test-as-specifier pred) ...)))) | |
1001 | ||
1002 | ;; Coerce to a predicate function: | |
1003 | (define (%test-as-specifier specifier) | |
1004 | (cond ((procedure? specifier) specifier) | |
1005 | ((integer? specifier) (test-match-nth 1 specifier)) | |
1006 | ((string? specifier) (test-match-name specifier)) | |
1007 | (else | |
1008 | (error "not a valid test specifier")))) | |
1009 | ||
1010 | (define-syntax test-skip | |
1011 | (syntax-rules () | |
1012 | ((test-skip pred ...) | |
1013 | (let ((runner (test-runner-get))) | |
1014 | (%test-runner-skip-list! runner | |
1015 | (cons (test-match-all (%test-as-specifier pred) ...) | |
1016 | (%test-runner-skip-list runner))))))) | |
1017 | ||
1018 | (define-syntax test-expect-fail | |
1019 | (syntax-rules () | |
1020 | ((test-expect-fail pred ...) | |
1021 | (let ((runner (test-runner-get))) | |
1022 | (%test-runner-fail-list! runner | |
1023 | (cons (test-match-all (%test-as-specifier pred) ...) | |
1024 | (%test-runner-fail-list runner))))))) | |
1025 | ||
1026 | (define (test-match-name name) | |
1027 | (lambda (runner) | |
1028 | (equal? name (test-runner-test-name runner)))) | |
1029 | ||
1030 | (define (test-read-eval-string string) | |
1031 | (let* ((port (open-input-string string)) | |
1032 | (form (read port))) | |
1033 | (if (eof-object? (read-char port)) | |
8fade76f MW |
1034 | (cond-expand |
1035 | (guile (eval form (current-module))) | |
1036 | (else (eval form))) | |
341c6fdd LC |
1037 | (cond-expand |
1038 | (srfi-23 (error "(not at eof)")) | |
1039 | (else "error"))))) | |
1040 |