source: project/test-infrastructure/test-infrastructure.scm @ 3

Last change on this file since 3 was 3, checked in by felix, 14 years ago

udp/test-infrastructure changes; added futures

File size: 31.6 KB
Line 
1;;;; test-infrastructure-hygienic.scm - Test-macros and support code
2;;;; Copyright (c) Peter K. Keller 2002
3;;;; Written by Peter K. Keller (psilord@cs.wisc.edu) for use with the CHICKEN
4;;;; scheme compiler and whoever else wants to use it. Just please include this
5;;;; little paragraph in any source code derived from the original. This
6;;;; source code is free to use for any purpose, but no warranty or guarantee
7;;;; to its stability or robustness is implied in any way. You may not hold me
8;;;; or anyone else liable for any use of this source code. Please try to keep
9;;;; this source code as close to R5RS(or later) scheme as possible. Thank you.
10
11;;;; Modifications Kon Lovett, Oct 15 2005
12
13;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14;; Wrap clause evaluation in an exception handler
15;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
16(define-syntax test:eval-clause-wrap
17        (syntax-rules ()
18                ((_ CURR-CLAUSE RESULTS EVAL-FORM)
19                        (call/cc
20                                (lambda (escape)
21                                        #;EVAL-FORM
22                                        (with-exception-handler
23                                                (lambda (the-exception)
24                                                        (escape
25                                                                (set! RESULTS
26                                                                        (cons (test:make-unexpected-exception-result
27                                                                                CURR-CLAUSE the-exception) RESULTS))))
28                                                (lambda () EVAL-FORM)))))))
29
30;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31;; perform a left to right evaluation of a list of expectations stopping at
32;; the first false one, and returning a list of all of the results from the
33;; evaluated expectations.
34;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35(define-syntax test:eval-expectations
36  (syntax-rules ()
37        ((_ CURR-CLAUSE RESULTS EXP)
38                (begin
39                        (set! CURR-CLAUSE 'EXP)
40                        (set! RESULTS (cons EXP RESULTS))))
41
42        ((_ CURR-CLAUSE RESULTS EXP-HEAD EXP-TAIL ...)
43                (begin
44                        (set! CURR-CLAUSE 'EXP-HEAD)
45                        (let ((head EXP-HEAD)) ;; evaluate EXP-HEAD right here!
46                                        ;; save the result, true or false, in the master list
47                                (set! RESULTS (cons head RESULTS))
48                                (if (test:test-case-clause-result? head)
49                                                ;; only continue evaluating down the list if the expectation
50                                                ;; turned out to be true
51                                        (test:eval-expectations CURR-CLAUSE RESULTS EXP-TAIL ...)))))))
52
53;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54;; perform a left to right evaluation of a list of exps returning a list of
55;; all of the results from the evaluated expectations.
56;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57(define-syntax test:eval-lr
58        (syntax-rules ()
59                ((_ CURR-CLAUSE RESULTS EXP)
60                        (begin
61                                (set! CURR-CLAUSE 'EXP)
62                                (set! RESULTS (cons EXP RESULTS))))
63
64                ((_ CURR-CLAUSE RESULTS EXP-HEAD EXP-TAIL ...)
65                        (begin
66                                (set! CURR-CLAUSE 'EXP-HEAD)
67                                (let ((head EXP-HEAD)) ;; evaluate EXP-HEAD right here!
68                                        (set! RESULTS (cons head RESULTS))
69                                        (test:eval-lr CURR-CLAUSE RESULTS EXP-TAIL ...))))))
70
71;; this is the definition of the macro test-case:
72;; (test-case DESC DEST-NAME TERM-NAME EXPECTATIONS)
73;; (test-case DESC DEST-NAME TERM-NAME (warn WARNING) EXPECTATIONS)
74;; (test-case DESC DEST-NAME TERM-NAME (FORMALS) EXPECTATIONS)
75;; (test-case DESC DEST-NAME TERM-NAME (warn WARNING) (FORMALS) EXPECTATIONS)
76;; DESC is an object (usually a string) that explains what the test-case is.
77;; DEST-NAME is the name of the destructor object provided for you in the
78;;      scope of the test-case(allows you to clean things up in case of
79;;      termination). The destructor object automatically when the expectations
80;;      have finished for any reason.
81;; TERM-NAME is the name of the escape function you must pass to (terminate ...)
82;;      when you want to abort the test case.
83;; EXPECTATIONS are a list of expect-* macros and destructor manipulation
84;;      calls. The first expectation that fails stops the evaluation in the test
85;;      case.
86;; WARNING is a string(actually any type, but usually string) message that
87;;      expains that something isn't quite right or there are special circumstances
88;;      to something.
89;; FORMALS are let-like bindings that become available to you inside the test
90;;      case.
91
92(define-syntax test-case
93  (syntax-rules (warn)
94
95        ;; NOTE: these rules are order dependent!
96
97    ;; support the optional let bindings with warning syntax
98    ((_ testname destname escape (warn warning) ((name value) ...) clauses ...)
99    ((lambda (name ...)
100        (let (  (warnobj warning)
101                        (tname testname)
102                        (destname (test:make-destructor)))
103          (let ([curr-clause '()] [test-result '()])
104                (test:eval-clause-wrap curr-clause test-result
105                        (test:eval-expectations curr-clause test-result clauses ...))
106                ;; call the destructor to get rid of anything the user didn't want
107                (destructor-activate! destname)
108                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
109                        ;; If the user exited via the terminate mechanism, then record this
110                        ;; fact with a real terminate node in the tree.
111                (cond ((terminate? stripped-test-result)
112                                (set! stripped-test-result
113                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
114                        ;; return the typed list for this kind of test result
115                (test:make-test-case-result (all-testcase-expectations-true? stripped-test-result)
116                        tname stripped-test-result warnobj))))) value ...))
117
118    ;; support the optional let bindings
119    ((_ testname destname escape ((name value) ...) clauses ...)
120     ((lambda (name ...)
121        (let ((tname testname) (destname (test:make-destructor)))
122          (let ([curr-clause '()] [test-result '()])
123                (test:eval-clause-wrap curr-clause test-result
124                        (test:eval-expectations curr-clause test-result clauses ...))
125                ;; call the destructor to get rid of anything the user didn't want
126                (destructor-activate! destname)
127                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
128                        ;; If the user exited via the terminate mechanism, then record this
129                        ;; fact with a real terminate node in the tree.
130                (cond ((terminate? stripped-test-result)
131                                (set! stripped-test-result
132                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
133                        ;; return the typed list for this kind of test result
134                (test:make-test-case-result
135                                (all-testcase-expectations-true? stripped-test-result)
136                                        tname stripped-test-result))))) value ...))
137
138
139    ;; no let bindings with warning syntax
140    ((_ testname destname escape (warn warning) clauses ...)
141     (let ((warnobj warning)
142                        (tname testname)
143                        (destname (test:make-destructor)))
144          (let ([curr-clause '()] [test-result '()])
145                (test:eval-clause-wrap curr-clause test-result
146                        (test:eval-expectations curr-clause test-result clauses ...))
147                ;; call the destructor to get rid of anything the user didn't want
148                (destructor-activate! destname)
149                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
150                        ;; If the user exited via the terminate mechanism, then record this
151                        ;; fact with a real terminate node in the tree.
152                (cond ((terminate? stripped-test-result)
153                                (set! stripped-test-result
154                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
155                        ;; return the typed list for this kind of test result
156                        (test:make-test-case-result
157                                (all-testcase-expectations-true? stripped-test-result)
158                                        tname stripped-test-result warnobj)))))
159
160    ;; no let bindings
161    ((_ testname destname escape clauses ...)
162     (let ((tname testname)
163                        (destname (test:make-destructor)))
164          (let ([curr-clause '()] [test-result '()])
165                (test:eval-clause-wrap curr-clause test-result
166                        (test:eval-expectations curr-clause test-result clauses ...))
167                ;; call the destructor to get rid of anything the user didn't want
168                (destructor-activate! destname)
169                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
170                        ;; If the user exited via the terminate mechanism, then record this
171                        ;; fact with a real terminate node in the tree.
172                (cond ((terminate? stripped-test-result)
173                                (set! stripped-test-result
174                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
175                        ;; return the typed list for this kind of test result
176                        (test:make-test-case-result
177                                (all-testcase-expectations-true? stripped-test-result)
178                                        tname stripped-test-result)))))))
179
180;; this is the definition of the macro test-package:
181;; (test-package DESC DEST-NAME TERM-NAME TESTCASES|TESTPACKAGES|EXPECTATIONS)
182;; (test-package DESC DEST-NAME TERM-NAME (warn WARNING) TESTCASES|TESTPACKAGES|EXPECTATIONS)
183;; (test-package DESC DEST-NAME TERM-NAME (FORMALS) TESTCASES|TESTPACKAGES|EXPECTATIONS)
184;; (test-package DESC DEST-NAME TERM-NAME (warn WARNING) (FORMALS) TESTCASES|TESTPACKAGES|EXPECTATIONS)
185;; DESC is an object (usually a string) that explains what the test-case is.
186;; DEST-NAME is the name of the destructor object provided for you in the
187;;      scope of the test-case(allows you to clean things up in case of
188;;      termination). The destructor object automatically when the expectations
189;;      have finished for any reason.
190;; TERM-NAME is the name of the escape function you must pass to (terminate ...)
191;;      when you want to abort the test case.
192;; TESTCASES|TESTPACKAGES|EXPECTATIONS is a list of test packages(they can nest)
193;;      or test cases or expectations. An expectation used bare in a test package
194;;      DOES NOT have the auto short circut behaviour that it would in a test-case.
195;;      Usually expectations are not placed bare into packages. However they
196;;      can be, and the result tree walking code wil have to deal with it specially.
197;; WARNING is a string(actually any type, but usually string) message that
198;;      expains that something isn't quite right or there are special circumstances
199;;      to something.
200;; FORMALS are let-like bindings that become available to you inside the test
201;;      package.
202(define-syntax test-package
203  (syntax-rules (warn)
204
205        ;; NOTE: these rules are order dependent!
206
207    ;; support the optional let bindings with warning syntax
208    ((_ packagename destname escape (warn warning) ((name value) ...) clauses ...)
209     ((lambda (name ...)
210        (let ((warnobj warning)
211                        (pname packagename) (destname (test:make-destructor)))
212          (let ([curr-clause '()] [test-result '()])
213                (test:eval-clause-wrap curr-clause test-result
214                        (test:eval-lr curr-clause test-result clauses ...))
215                ;; call the destructor to get rid of anything the user didn't want
216                (destructor-activate! destname)
217                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
218                        ;; If the user exited via the terminate mechanism, then record this
219                        ;; fact with a real terminate node in the tree.
220                (cond ((terminate? stripped-test-result)
221                                (set! stripped-test-result
222                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
223                        ;; return the typed list for this kind of test result
224                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result)
225                        pname stripped-test-result warnobj))))) value ...))
226
227    ;; support the optional let bindings
228    ((_ packagename destname escape ((name value) ...) clauses ...)
229     ((lambda (name ...)
230        (let ((pname packagename) (destname (test:make-destructor)))
231          (let ([curr-clause '()] [test-result '()])
232                (test:eval-clause-wrap curr-clause test-result
233                        (test:eval-lr curr-clause test-result clauses ...))
234                ;; call the destructor to get rid of anything the user didn't want
235                (destructor-activate! destname)
236                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
237                        ;; If the user exited via the terminate mechanism, then record this
238                        ;; fact with a real terminate node in the tree.
239                (cond ((terminate? stripped-test-result)
240                                (set! stripped-test-result
241                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
242                        ;;      return the typed list for this kind of test result
243                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result)
244                        pname stripped-test-result))))) value ...))
245
246    ;; no let bindings with warning syntax
247    ((_ packagename destname escape (warn warning) clauses ...)
248     (let (     (warnobj warning)
249                        (pname packagename) (destname (test:make-destructor)))
250          (let ([curr-clause '()] [test-result '()])
251                (test:eval-clause-wrap curr-clause test-result
252                        (test:eval-lr curr-clause test-result clauses ...))
253                ;; call the destructor to get rid of anything the user didn't want
254                (destructor-activate! destname)
255                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
256                        ;; If the user exited via the terminate mechanism, then record this
257                        ;; fact with a real terminate node in the tree.
258                (cond ((terminate? stripped-test-result)
259                                (set! stripped-test-result
260                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
261                        ;; return the typed list for this kind of test result
262                        (test:make-test-package-result (all-testpackage-results-true? stripped-test-result)
263                                pname stripped-test-result warnobj)))))
264
265    ;; no let bindings
266    ((_ packagename destname escape clauses ...)
267     (let ((pname packagename) (destname (test:make-destructor)))
268          (let ([curr-clause '()] [test-result '()])
269                (test:eval-clause-wrap curr-clause test-result
270                        (test:eval-lr curr-clause test-result clauses ...))
271                ;; call the destructor to get rid of anything the user didn't want
272                (destructor-activate! destname)
273                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
274                        ;; If the user exited via the terminate mechanism, then record this
275                        ;; fact with a real terminate node in the tree.
276                (cond ((terminate? stripped-test-result)
277                                (set! stripped-test-result
278                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
279                        ;; return the typed list for this kind of test result
280                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result)
281                        pname stripped-test-result)))))))
282
283;;;;;;;;;;;;;;;;;;
284;; evaluate the side effect expressions and return an ignored result no matter
285;; what happens. Maybe some other day I might specialize this for some purpose.
286;; (side-effect EXP)
287(define-syntax side-effect
288        (syntax-rules ()
289        ((_ clauses ...)
290                (begin clauses ...
291                        (test:make-ignore-result)))))
292
293;; the macro the user uses to create the todo
294;; (todo MESSAGE)
295;; (todo MESSAGE (warn WARNING))
296(define-syntax todo
297        (syntax-rules (warn)
298
299        ;; with warning syntax
300        ((_ message (warn warning))
301                (let ((warnobj warning) (msg message))
302                        (test:make-todo-result msg warnobj)))
303
304        ;; without warning syntax
305        ((_ message)
306                (let ((msg message))
307                        (test:make-todo-result msg)))))
308
309;; the macro the user uses to create the gloss
310;; (gloss MESSAGE)
311;; (gloss MESSAGE (warn WARNING))
312(define-syntax gloss
313        (syntax-rules (warn)
314
315        ;; with warning syntax
316        ((_ message (warn warning))
317                (let ((warnobj warning) (msg message))
318                        (test:make-gloss-result msg warnobj)))
319
320        ;; without warning syntax
321        ((_ message)
322                (let ((msg message))
323                        (test:make-gloss-result msg)))))
324
325;; the macro the user uses to create a skipped entity. The clauses that
326;; come in the skip are just totally removed and not even computed by the
327;; macro.
328;; (skip MESSAGE clauses ...)
329;; (skip MESSAGE (warn WARNING) clauses ...)
330(define-syntax skip
331        (syntax-rules (warn)
332
333        ;; with warning syntax
334        ((_ message (warn warning) clauses ...) ;; ignore the clauses
335                (let ((warnobj warning) (msg message))
336                        (test:make-skip-result msg warnobj)))
337
338        ;; without warning syntax
339        ((_ message clauses ...) ;; ignore the clauses
340                (let ((msg message))
341                        (test:make-skip-result msg)))))
342
343
344;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
345;; expect-zero: Expect a value that will be exactly zero
346;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
347
348(define-syntax expect-zero
349  (syntax-rules (warn)
350
351        ;; with optional warning syntax
352        ((_ msg (warn warning) val)
353     (let ((warnobj warning) (message msg) (value val))
354       (let ((result (test:_expect-zero message value)))
355                 (test:make-expect-result result "zero" message 'val value warnobj))))
356
357        ;; without optional warning syntax
358    ((_ msg val)
359     (let ((message msg) (value val))
360       (let ((result (test:_expect-zero message value)))
361                 (test:make-expect-result result "zero" message 'val value))))))
362
363
364;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
365;; expect-nonzero: Expect a value to be non-zero
366;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
367
368(define-syntax expect-nonzero
369  (syntax-rules (warn)
370
371        ;; with optional warning syntax
372    ((_ msg (warn warning) val)
373     (let ((warnobj warning) (message msg) (value val))
374       (let ((result (test:_expect-nonzero message value)))
375                (test:make-expect-result result "nonzero" message 'val value warnobj))))
376
377        ;; without optional warning syntax
378    ((_ msg val)
379     (let ((message msg) (value val))
380       (let ((result (test:_expect-nonzero message value)))
381                (test:make-expect-result result "nonzero" message 'val value))))))
382
383
384;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
385;; expect-true: Expect a value to be #t
386;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
387
388(define-syntax expect-true
389  (syntax-rules (warn)
390
391        ;; with optional warning syntax
392    ((_ msg (warn warning) val)
393     (let ((warnobj warning) (message msg) (value val))
394       (let ((result (test:_expect-true message value)))
395                (test:make-expect-result result "true" message 'val value warnobj))))
396
397        ;; without optional warning syntax
398    ((_ msg val)
399     (let ((message msg) (value val))
400       (let ((result (test:_expect-true message value)))
401                (test:make-expect-result result "true" message 'val value))))))
402
403
404;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
405;; expect-false: Expect a value to be #f
406;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
407
408(define-syntax expect-false
409  (syntax-rules (warn)
410
411        ;; with optional warning syntax
412    ((_ msg (warn warning) val)
413     (let ((warnobj warning) (message msg) (value val))
414       (let ((result (test:_expect-false message value)))
415                (test:make-expect-result result "false" message 'val value warnobj))))
416
417        ;; without optional warning syntax
418    ((_ msg val)
419     (let ((message msg) (value val))
420       (let ((result (test:_expect-false message value)))
421                (test:make-expect-result result "false" message 'val value))))))
422
423
424;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
425;; expect-eq: Expect the eq? relation to hold between val and arg
426;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
427
428(define-syntax expect-eq
429  (syntax-rules (warn)
430
431        ;; with optional warning syntax
432    ((expect-eq msg (warn warning) val arg)
433     (let ((warnobj warning) (message msg) (value val) (argument arg))
434       (let ((result (test:_expect-eq message value argument)))
435                (test:make-expect-equivalence-result result "eq" message
436                        value 'arg argument warnobj))))
437
438        ;; without optional warning syntax
439    ((expect-eq msg val arg)
440     (let ((message msg) (value val) (argument arg))
441       (let ((result (test:_expect-eq message value argument)))
442                (test:make-expect-equivalence-result result "eq" message
443                        value 'arg argument))))))
444
445
446;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
447;; expect-eqv: Expect the eqv? relation to hold between val and arg
448;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
449
450(define-syntax expect-eqv
451  (syntax-rules (warn)
452
453        ;; with optional warning syntax
454    ((_ msg (warn warning) val arg)
455     (let ((warnobj warning) (message msg) (value val) (argument arg))
456       (let ((result (test:_expect-eqv message value argument)))
457                (test:make-expect-equivalence-result result "eqv" message
458                        value 'arg argument warnobj))))
459
460        ;; without optional warning syntax
461    ((_ msg val arg)
462     (let ((message msg) (value val) (argument arg))
463       (let ((result (test:_expect-eqv message value argument)))
464                (test:make-expect-equivalence-result result "eqv" message
465                        value 'arg argument))))))
466
467
468;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
469;; expect-equal: Expect the equal? relation to hold between val and arg
470;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
471
472(define-syntax expect-equal
473  (syntax-rules (warn)
474
475        ;; with optional warning syntax
476    ((_ msg (warn warning) val arg)
477     (let ((warnobj warning) (message msg) (value val) (argument arg))
478       (let ((result (test:_expect-equal message value argument)))
479                (test:make-expect-equivalence-result result "equal" message
480                        value 'arg argument warnobj))))
481
482        ;; without optional warning syntax
483    ((_ msg val arg)
484     (let ((message msg) (value val) (argument arg))
485       (let ((result (test:_expect-equal message value argument)))
486                (test:make-expect-equivalence-result result "equal" message
487                        value 'arg argument))))))
488
489
490;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
491;; expect-near: Expect a value within a certain tolerance
492;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
493
494(define-syntax expect-near
495  (syntax-rules (warn)
496
497        ;; with optional warning syntax
498    ((_ msg (warn warning) val tol arg)
499     (let (     (warnobj warning) (message msg) (value val) (tolerance tol)
500                        (argument arg))
501       (let ((result (test:_expect-near message value tolerance argument)))
502                (test:make-expect-tolerance-result result "near" message
503                        value tol 'arg argument warnobj))))
504
505        ;; without optional warning syntax
506    ((_ msg val tol arg)
507     (let ((message msg) (value val) (tolerance tol) (argument arg))
508       (let ((result (test:_expect-near message value tolerance argument)))
509                (test:make-expect-tolerance-result result "near" message
510                        value tol 'arg argument))))))
511
512
513;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
514;; expect-positive: Expect a number to be positive
515;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
516
517(define-syntax expect-positive
518  (syntax-rules (warn)
519
520        ;; with optional warning syntax
521    ((_ msg (warn warning) val)
522     (let ((warnobj warning) (message msg) (value val))
523       (let ((result (test:_expect-positive message value)))
524                (test:make-expect-result result "positive" message 'val value warnobj))))
525
526        ;; without optional warning syntax
527    ((_ msg val)
528     (let ((message msg) (value val))
529       (let ((result (test:_expect-positive message value)))
530                (test:make-expect-result result "positive" message 'val value))))))
531
532
533;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
534;; expect-negative: Expect a number to be negative.
535;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
536
537(define-syntax expect-negative
538  (syntax-rules (warn)
539
540        ;; with optional warning syntax
541    ((_ msg (warn warning) val)
542     (let ((warnobj warning) (message msg) (value val))
543       (let ((result (test:_expect-negative message value)))
544                (test:make-expect-result result "negative" message 'val value warnobj))))
545
546        ;; without optional warning syntax
547    ((_ msg val)
548     (let ((message msg) (value val))
549       (let ((result (test:_expect-negative message value)))
550                (test:make-expect-result result "negative" message 'val value))))))
551
552
553;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
554;; expect-not-false: Expect a non-false result.
555;;
556;; Could be done with (expect-true MSG (not (not VAL)))
557;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
558
559(define-syntax expect-not-false
560  (syntax-rules (warn)
561
562        ;; with optional warning syntax
563    ((_ msg (warn warning) val)
564     (let ((warnobj warning) (message msg) (value val))
565       (let ((result (test:_expect-not-false message value)))
566                (test:make-expect-result result "not-false" message 'val value warnobj))))
567
568        ;; without optional warning syntax
569    ((_ msg val)
570     (let ((message msg) (value val))
571       (let ((result (test:_expect-not-false message value)))
572                (test:make-expect-result result "not-false" message 'val value))))))
573
574;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
575;; expect-values: Expect a multi-valued result.
576;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
577
578(define-syntax expect-values
579  (syntax-rules (warn)
580
581; value probably not reasonable output for message - need something else
582
583        ;; with optional warning syntax
584    ((_ msg (warn warning) val arg)
585     (let ((warnobj warning) (message msg) (value val) (argument (receive arg)))
586       (let ((result (test:_expect-values message value argument)))
587                (test:make-expect-equivalence-result result "values" message
588                        value 'arg argument warnobj))))
589
590        ;; without optional warning syntax
591    ((_ msg val arg)
592     (let ((message msg) (value val) (argument (receive arg)))
593       (let ((result (test:_expect-values message value argument)))
594                (test:make-expect-equivalence-result result "values" message
595                        value 'arg argument))))))
596
597
598;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
599;; expect-values support
600;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601
602(define-syntax test:expect-values-test
603  (syntax-rules (warn)
604
605        ;; with optional warning syntax
606    ((_ msg (warn warning) val arg test name)
607     (let ((warnobj warning) (message msg) (value val) (argument (receive arg)))
608       (let ((result (test message value argument)))
609                (test:make-expect-equivalence-result result name message
610                        value 'arg argument warnobj))))
611
612        ;; without optional warning syntax
613    ((_ msg val arg test name)
614     (let ((message msg) (value val) (argument (receive arg)))
615       (let ((result (test message value argument)))
616                (test:make-expect-equivalence-result result name message
617                        value 'arg argument))))))
618
619
620;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
621;; expect-values-eq: Expect a multi-valued result.
622;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
623
624(define-syntax expect-values-eq
625  (syntax-rules (warn)
626
627        ;; with optional warning syntax
628    ((_ msg (warn warning) val arg)
629        (test:expect-values-test msg (warn warning) val arg test:_expect-values-eq "values-eq"))
630
631        ;; without optional warning syntax
632    ((_ msg val arg)
633        (test:expect-values-test msg val arg test:_expect-values-eq "values-eq"))))
634
635
636;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
637;; expect-values-eqv: Expect a multi-valued result.
638;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
639
640(define-syntax expect-values-eqv
641  (syntax-rules (warn)
642
643        ;; with optional warning syntax
644    ((_ msg (warn warning) val arg)
645        (test:expect-values-test msg (warn warning) val arg test:_expect-values-eqv "values-eqv"))
646
647        ;; without optional warning syntax
648    ((_ msg val arg)
649        (test:expect-values-test msg val arg test:_expect-values-eqv "values-eqv"))))
650
651
652;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
653;; expect-values-equal: Expect a multi-valued result.
654;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
655
656(define-syntax expect-values-equal
657  (syntax-rules (warn)
658
659        ;; with optional warning syntax
660    ((_ msg (warn warning) val arg)
661        (test:expect-values-test msg (warn warning) val arg test:_expect-values-equal "values-equal"))
662
663        ;; without optional warning syntax
664    ((_ msg val arg)
665        (test:expect-values-test msg val arg test:_expect-values-equal "values-equal"))))
666
667
668;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
669;; expect-exception support.
670;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
671
672(define-syntax test:gen-exception-property-test
673        (syntax-rules (and or not)
674
675                ((_ EXP KIND-KEY ()) #t)
676
677                ((_ EXP KIND-KEY (and PROP-EXPR PROP-EXPRS ...))
678                        (and (test:gen-exception-property-test EXP KIND-KEY PROP-EXPR)
679                                (test:gen-exception-property-test EXP KIND-KEY (PROP-EXPRS ...))))
680
681                ((_ EXP KIND-KEY (or PROP-EXPR PROP-EXPRS ...))
682                        (or (test:gen-exception-property-test EXP KIND-KEY PROP-EXPR)
683                                (test:gen-exception-property-test EXP KIND-KEY (PROP-EXPRS ...))))
684
685                ((_ EXP KIND-KEY (not PROP-EXPR))
686                        (not (test:gen-exception-property-test EXP KIND-KEY PROP-EXPR)))
687
688                ((_ EXP KIND-KEY (BIN-OP PROP-KEY VAL))
689                        (BIN-OP (test:gen-exception-property-test EXP KIND-KEY PROP-KEY) VAL))
690
691                ((_ EXP KIND-KEY (PROP-KEY VAL))
692                        (equal? (test:gen-exception-property-test EXP KIND-KEY PROP-KEY) VAL))
693
694                ((_ EXP KIND-KEY (PROP-KEY PROP-KEYS ...))
695                        (and (test:gen-exception-property-test EXP KIND-KEY PROP-KEY)
696                                (test:gen-exception-property-test EXP KIND-KEY (PROP-KEYS ...))))
697
698                        ; use of #f as an undefined property value is problematic
699                ((_ EXP KIND-KEY PROP-KEY)
700                        #;(test:has-condition-property
701                                (condition-property-accessor 'KIND-KEY 'PROP-KEY) EXP)
702                        ((condition-property-accessor 'KIND-KEY 'PROP-KEY #f) EXP))))
703
704(define-syntax test:gen-exception-test
705        (syntax-rules (and or not property)
706
707                ((_ EXP ()) #t)
708
709                ((_ EXP (and COND-EXPR COND-EXPRS ...))
710                        (and (test:gen-exception-test EXP COND-EXPR)
711                                (test:gen-exception-test EXP (COND-EXPRS ...))))
712
713                ((_ EXP (or COND-EXPR COND-EXPRS ...))
714                        (or (test:gen-exception-test EXP COND-EXPR)
715                                (test:gen-exception-test EXP (COND-EXPRS ...))))
716
717                ((_ EXP (not COND-EXPR))
718                        (not (test:gen-exception-test EXP COND-EXPR)))
719
720                ((_ EXP (property KIND-KEY PROP-EXPR ...))
721                        (and (test:gen-exception-test EXP KIND-KEY)
722                                (test:gen-exception-property-test EXP KIND-KEY (PROP-EXPR ...))))
723
724                ((_ EXP (KIND-KEY KIND-KEYS ...))
725                        (and (test:gen-exception-test EXP KIND-KEY)
726                                (test:gen-exception-test EXP (KIND-KEYS ...))))
727
728                ((_ EXP KIND-KEY) ((condition-predicate 'KIND-KEY) EXP))))
729
730
731;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
732;; expect-exception: Expect an exception.
733;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
734
735(define-syntax expect-exception
736        (syntax-rules (warn)
737
738                ;; with optional warning syntax
739                ((_ msg (warn warning) exn arg)
740                         (let ([warnobj warning] [message msg])
741                                 (letrec ([caught #f] [argument
742                                        (call/cc (lambda (k)
743                                                (with-exception-handler
744                                                        (lambda (the-exception)
745                                                                (let ([r (test:gen-exception-test the-exception exn)])
746                                                                        (set! caught #t)
747                                                                        (k r)))
748                                                        (lambda () (k arg)))))])
749                                        (let ((result (test:_expect-exception message 'exn argument caught)))
750                                                (test:make-expect-equivalence-result result "exception"
751                                                        message 'exn 'arg argument warnobj)))))
752
753                ;; without optional warning syntax
754                ((_ msg exn arg)
755                         (let ([message msg])
756                                 (letrec ([message msg] [caught #f] [argument
757                                        (call/cc (lambda (k)
758                                                (with-exception-handler
759                                                        (lambda (the-exception)
760                                                                (let ([r (test:gen-exception-test the-exception exn)])
761                                                                        (set! caught #t)
762                                                                        (k r)))
763                                                        (lambda () (k arg)))))])
764                                        (let ((result (test:_expect-exception message 'exn argument caught)))
765                                                (test:make-expect-equivalence-result result "exception"
766                                                        message 'exn 'arg argument)))))))
767
768
769;;;;;;;;;;;;;;;;;;
770;; This next macro and subsequent invocations describe the API by which you
771;; may inspect a statistics object.
772;;;;;;;;;;;;;;;;;;
773
774;; Allow me to define all of the stats API functions that interact
775;; with the black box statistics object. In this case, the black box is
776;; a vector.
777(define-syntax test:gen-stat-API-func
778(syntax-rules (set incr decr ref)
779        ((_ set fname idx)
780                (define fname
781                        (lambda (statobj val)
782                                (vector-set! statobj val idx))))
783        ((_ incr fname idx)
784                (define fname
785                        (lambda (statobj)
786                                (vector-set! statobj idx (+ (vector-ref statobj idx) 1)))))
787        ((_ decr fname idx)
788                (define fname
789                        (lambda (statobj)
790                                (vector-set! statobj idx (- (vector-ref statobj idx) 1)))))
791        ((_ ref fname idx)
792                (define fname
793                        (lambda (statobj)
794                                (vector-ref statobj idx))))))
Note: See TracBrowser for help on using the repository browser.