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

Last change on this file since 1 was 1, checked in by azul, 14 years ago

Import everything.

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