Changeset 2551 in project


Ignore:
Timestamp:
12/04/06 08:06:05 (15 years ago)
Author:
Kon Lovett
Message:

Save of 2.0 pre-release.

Location:
test-infrastructure
Files:
1 added
1 deleted
10 edited

Legend:

Unmodified
Added
Removed
  • test-infrastructure/test-infrastructure-fp.scm

    r1701 r2551  
    1919        test:_expect-near)
    2020  )
    21 
    22         (cond-expand
    23                 [paranoia]
    24                 [else
    25                         (declare
    26                                 (no-procedure-checks)
    27                                 (no-argc-checks)
    28                                 (no-bound-checks))]
    29         )
    3021)
    3122
  • test-infrastructure/test-infrastructure-output.scm

    r1701 r2551  
    1212;;;; Modifications Kon Lovett, Oct 15 2005
    1313
    14 (use lolevel test-infrastructure-support test-infrastructure-runtime test-infrastructure-stat)
     14(use test-infrastructure-support test-infrastructure-runtime test-infrastructure-stat)
    1515
    1616(eval-when (compile)
     
    1818        (usual-integrations)
    1919                (inline)
    20                 (lambda-lift)
    2120                (fixnum)
    2221    (export
    2322                        test:display-indent
    2423                        test:write-object
    25                         test:display-objects test:display-objects-newline
    26                         test:display-indented-objects test:display-indented-objects-newline
     24                        test:display-object
     25                        test:display-objects
     26                        test:display-objects-newline
     27                        test:display-indented-objects
     28                        test:display-indented-objects-newline
    2729                        test:output-apply
    2830                output-style-human
    2931                output-style-html
    30                 output-text-compact output-style-compact
     32                output-style-compact
    3133                output-style-minimal)
    3234  )
    33 
    34         (cond-expand
    35                 [paranoia]
    36                 [else
    37                         (declare
    38                                 (no-procedure-checks)
    39                                 (no-argc-checks)
    40                                 (no-bound-checks))]
    41         )
    4235)
    4336
    4437;;;
    4538
    46 (define-macro (length>1? LST)
    47         `(and (pair? ,LST) (pair? (cdr ,LST))))
     39(define (length>1? lst)
     40        (and (pair? lst) (pair? (cdr lst))) )
    4841
    4942;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    6356;; CHICKEN SPECIFIC!
    6457
    65 (define (test:display-condition obj)
     58(define (test:display-condition c)
    6659
    6760        (define (display-condition-key keys)
     
    9285
    9386        (define (display-condition el pl)
    94                 (display "(exception ")
     87                (display "(condition ")
    9588                (display-condition-keys el)
    9689                (display " ")
     
    9891                (display ")"))
    9992
    100                 (let ([v (record->vector obj)])
    101                         (display-condition (vector-ref v 1) (vector-ref v 2))))
     93                (display-condition (##sys#slot c 1) (##sys#slot c 2)))
    10294
    10395(define (test:write-object obj)
     
    10698                (write obj)))
    10799
     100(define (test:display-object obj)
     101        (if (condition? obj)
     102                (test:display-condition obj)
     103                (display obj)))
     104
    108105(define (test:display-objects . args)
    109         (for-each display args))
     106        (for-each test:display-object args))
    110107
    111108(define (test:display-objects-newline . args)
     
    809806                                                                        (when (*-result-timing-active? resnode)
    810807                                                                                (test:display-indented-objects-newline indent
    811                                                                                         "Time: " (*-result-timing-message resnode)))
     808                                                                                        "Time " (*-result-timing-message resnode)))
    812809
    813810                                                                        (test:display-indented-objects indent "   Expected: ")
     
    920917(define (test:output-apply thunk dest)
    921918        (cond
    922                 ((not dest) (thunk))
    923                 ((port? dest) (with-output-to-port dest thunk))
    924                 ((string? dest) (with-output-to-file dest thunk))
    925                 (else (with-output-to-string thunk))))
     919                [(not dest) (thunk)]
     920                [(port? dest) (with-output-to-port dest thunk)]
     921                [(string? dest) (with-output-to-file dest thunk)]
     922                [else (with-output-to-string thunk)] ) )
    926923
    927924(define (output-style-human resnode . r)
     
    931928        (test:output-apply (lambda () (test:display-html-verbose resnode)) (:optional r #f)))
    932929
    933 (define (output-text-compact resnode . r)
     930(define (output-style-compact resnode . r)
    934931        (test:output-apply (lambda () (test:display-text-compact resnode)) (:optional r #f)))
    935 
    936 (define output-style-compact output-text-compact)
    937932
    938933(define (output-style-minimal resnode . r)
  • test-infrastructure/test-infrastructure-runtime.scm

    r1756 r2551  
    1212;;;; Modifications Kon Lovett, Oct 15 2005
    1313
    14 (use syntax-case srfi-9 test-infrastructure-timing)
     14(use srfi-1 srfi-9 test-infrastructure-state)
    1515
    1616(eval-when (compile)
     
    1818        (usual-integrations)
    1919                (inline)
    20                 (lambda-lift)
    2120                (bound-to-procedure
    22                         *-result-timing-active? *-result-timing-ref)
     21                        *-result-timing-active?
     22                        *-result-timing-ref)
     23                (export ; Unused
     24                        test:ignore-result
     25                        test:terminate-result
     26                        test:expect-tolerance-result
     27                        test:expect-equivalence-result
     28                        test:test-package-result
     29                        test:test-case-result
     30                        test:skip-result
     31                        test:expect-result
     32                        test:warning?
     33                        test:warning
     34                        test:user-termination
     35                        test:gloss-result
     36                        test:todo-result
     37                        test:timing-result)
    2338    (export
    2439                        test:timing-active?
     
    3247                        test:make-skip-result test:make-expect-result test:make-expect-equivalence-result
    3348                        test:make-expect-tolerance-result
     49                        test:make-ignore-result
     50                        test:make-user-termination
    3451                        test:warning-active? test:warning-message-ref
    3552                        test-case-result? test-case-result-kind-ref
     
    5774                        expect-tolerance-result-rhs-evaled-ref expect-tolerance-result-warning? expect-tolerance-result-warning-ref
    5875                        expect-tolerance-result-id-ref
    59                         terminate? terminate-message-ref terminate-result?
     76                        user-termination? user-termination-message-ref terminate-result?
    6077                        terminate-result-kind-ref terminate-result-result-ref terminate-result-result?
    6178                        terminate-result-scope-ref terminate-result-container-ref terminate-result-message-ref
     
    6784                        skip-result? skip-result-message-ref skip-result-warning?
    6885                        skip-result-warning-ref skip-result-id-ref
     86                        ignore-result?
    6987                        destructor-atexit! destructor-activate! destructor-clear! destructor-dump
    7088                        *-result-timing-active? *-result-timing-values-ref
    7189                        *-result? *-result-ref *-warning?
    7290                        all-testpackage-results-true? all-testcase-expectations-true?
    73                         terminate
    7491                        walk-test-named-structure)
    75         )
    76 
    77         (cond-expand
    78                 [paranoia]
    79                 [else
    80                         (declare
    81                                 (no-procedure-checks)
    82                                 #;(no-argc-checks)
    83                                 (no-bound-checks))]
    8492        )
    8593)
     
    98106;;;;;;;;;;;;;;;;;;
    99107
    100 (define-syntax test:gen-label
    101         (syntax-rules ()
    102                 [(_) (gensym 'tr)]
    103         ))
     108(define-inline (test:gen-label)
     109        (gensym 'tr) )
    104110
    105111;;;;;;;;;;;;;;;;;;
     
    130136
    131137(define-record-type test:timing-result
    132         (%test:make-timing msg-lst)
    133         test:timing?
     138        (%test:make-timing-result msg-lst)
     139        test:timing-result?
    134140        (msg-lst test:timing-msg-lst)
    135141)
    136142
    137143(define (test:timing-active? timing)
    138         (and (test:timing? timing)
     144        (and (test:timing-result? timing)
    139145                         (not (null? (test:timing-msg-lst timing)))) )
    140146
     
    145151        (cadr (test:timing-msg-lst timing)) )
    146152
    147 (define (test:make-timing #!optional result-list)
    148         (%test:make-timing
     153(define (test:make-timing state #!optional result-list)
     154        (%test:make-timing-result
    149155                (if result-list
    150156                        (let loop ([lst result-list] [timed? #f] [usr 0] [sys 0])
     
    154160                                                (if (*-result-timing-active? res)
    155161                                                        (let ([timing (*-result-timing-ref res)])
    156                                                                 (loop (cdr lst) #t
     162                                                                (loop
     163                                                                        (cdr lst)
     164                                                                        #t
    157165                                                                        (+ usr (test:timing-user-time-ref timing))
    158                                                                         (+ sys (test:timing-system-time-ref timing))) )
    159                                                                 (loop (cdr lst) timed? usr sys)) )) )
    160                         (if test:do-timing?
    161                                 (test:timer)
     166                                                                        (+ sys (test:timing-system-time-ref timing))))
     167                                                                (loop (cdr lst) timed? usr sys)))))
     168                        (if (test:timing? state)
     169                                ((test:timer state))
    162170                                '()))) )
    163171
     
    180188)
    181189
    182 (define (test:make-test-case-result bool message expect-list . warning)
    183         (%test:make-test-case-result bool (or message "") expect-list
    184                 (test:make-warning warning) (test:make-timing expect-list) (test:gen-label)))
     190(define (test:make-test-case-result state result message expect-list . warning)
     191        (%test:make-test-case-result result (or message "") expect-list
     192                (test:make-warning warning) (test:make-timing state expect-list) (test:gen-label)))
    185193
    186194;;
     
    218226)
    219227
    220 (define (test:make-test-package-result bool message result-list . warning)
    221         (%test:make-test-package-result bool (or message "") result-list
    222                 (test:make-warning warning) (test:make-timing result-list) (test:gen-label)))
     228(define (test:make-test-package-result state result message result-list . warning)
     229        (%test:make-test-package-result result (or message "") result-list
     230                (test:make-warning warning) (test:make-timing state result-list) (test:gen-label)))
    223231
    224232;;
     
    258266)
    259267
    260 (define (test:make-expect-result result specific message unevaled evaled . warning)
     268(define (test:make-expect-result state result specific message unevaled evaled . warning)
    261269        (%test:make-expect-result result specific (or message "") unevaled evaled
    262                 (test:make-warning warning) (test:make-timing) (test:gen-label)))
     270                (test:make-warning warning) (test:make-timing state) (test:gen-label)))
    263271
    264272;;
     
    299307)
    300308
    301 (define (test:make-expect-equivalence-result result specific message lhs rhs-unevaled rhs-evaled . warning)
     309(define (test:make-expect-equivalence-result state result specific message lhs rhs-unevaled rhs-evaled . warning)
    302310        (%test:make-expect-equivalence-result result specific (or message "") lhs rhs-unevaled rhs-evaled
    303                 (test:make-warning warning) (test:make-timing) (test:gen-label)))
     311                (test:make-warning warning) (test:make-timing state) (test:gen-label)))
    304312
    305313;;
     
    341349)
    342350
    343 (define (test:make-expect-tolerance-result result style message lhs tol rhs-unevaled rhs-evaled . warning)
     351(define (test:make-expect-tolerance-result state result style message lhs tol rhs-unevaled rhs-evaled . warning)
    344352        (%test:make-expect-tolerance-result result style (or message "") lhs tol rhs-unevaled rhs-evaled
    345                 (test:make-warning warning) (test:make-timing) (test:gen-label)))
     353                (test:make-warning warning) (test:make-timing state) (test:gen-label)))
    346354
    347355;;
     
    377385)
    378386
    379 (define (test:make-terminate-result result scope container message)
    380         (%test:make-terminate-result result scope container (terminate-message-ref message)
     387(define (test:make-terminate-result state result scope container usrtrm)
     388        (%test:make-terminate-result result scope container (user-termination-message-ref usrtrm)
    381389                (test:gen-label)))
    382390
     
    398406(define-record-type test:user-termination
    399407        (test:make-user-termination message)
    400         terminate?
    401         (message terminate-message-ref)
    402 )
    403 
    404 (define (terminate efunc message)
    405         (efunc (test:make-user-termination message)))
     408        user-termination?
     409        (message user-termination-message-ref)
     410)
    406411
    407412;;;;;;;;;;;;;;;;;;
     
    473478)
    474479
    475 (define (test:make-skip-result message . warning)
     480(define (test:make-skip-result state message . warning)
    476481        (%test:make-skip-result message (test:make-warning warning) (test:gen-label)))
    477482
     
    483488(define (skip-result-warning-ref res)
    484489        (test:warning-message-ref (skip-result-warning res)))
     490
     491;;;;;;;;;;;;;;;;;;
     492;; make a result type that is "ignored". This takes care of things like
     493;; using the destructor object in a sequence of expectations.
     494;;;;;;;;;;;;;;;;;;
     495
     496(define-record-type test:ignore-result
     497        (%test:make-ignore-result)
     498        ignore-result?
     499)
     500
     501(define (test:make-ignore-result state)
     502        (%test:make-ignore-result) )
    485503
    486504;;;;;;;;;;;;;;;;;;
     
    499517
    500518(define (destructor-atexit! dobj . args)
    501         (apply dobj `(,'atexit ,@args)))
     519        (apply dobj `(atexit ,@args)))
    502520
    503521(define (destructor-activate! dobj . args)
    504         (apply dobj `(,'activate ,@args)))
     522        (apply dobj `(activate ,@args)))
    505523
    506524(define (destructor-clear! dobj . args)
    507         (apply dobj `(,'clear ,@args)))
     525        (apply dobj `(clear ,@args)))
    508526
    509527(define (destructor-dump dobj . args)
    510         (apply dobj `(,'dump ,@args)))
     528        (apply dobj `(dump ,@args)))
    511529
    512530;;;;;;;;;;;;;;;;;;
     
    702720;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    703721
    704 ;; FIXME can I get rid of the explicit stack?
    705 
    706 (define (walk-test-named-structure proc alist #!optional (level 0) (trail '()))
    707         (when (pair? alist)
    708                 (let ([elm (car alist)]
    709                                         [parent (if (pair? trail) (car trail) #f)])
    710                         (if (pair? elm)
    711                                 (let ([typ (car elm)])
    712                                         (switch typ
    713                                                 ['thunk
    714                                                         (case parent
    715                                                                 [(thunk package case expect)
    716                                                                         (set! trail (cdr trail))
    717                                                                         (set! level (sub1 level))])]
    718                                                 ['package
    719                                                         (case parent
    720                                                                 [(thunk package)
    721                                                                         (set! level (add1 level))]
    722                                                                 [(case expect)
    723                                                                         (set! trail (cdr trail))
    724                                                                         (set! level (sub1 level))])]
    725                                                 ['case
    726                                                         (case parent
    727                                                                 [(thunk package)
    728                                                                         (set! level (add1 level))]
    729                                                                 [(case)
    730                                                                         (set! trail (cdr trail))]
    731                                                                 [(expect)
    732                                                                         (set! trail (cdr trail))
    733                                                                         (set! level (sub1 level))])]
    734                                                 ['expect
    735                                                         (case parent
    736                                                                 [(package case)
    737                                                                         (set! level (add1 level))]
    738                                                                 [(expect)
    739                                                                         (set! trail (cdr trail))])]
    740                                                 [else
    741                                                         (error 'walk-test-named-structure "unknown named structure element" elm)])
    742                                         (proc level typ (cdr elm))
    743                                         (walk-test-named-structure proc (cdr alist) level (cons typ trail)) )
    744                                 (error 'walk-test-named-structure "unknown named structure element" elm)) )) )
     722;FIXME can I get rid of the explicit stack ('trail')?
     723(define (walk-test-named-structure proc test-element-names)
     724        (let loop ([alist test-element-names] [level 0] [trail '()])
     725                (when (pair? alist)
     726                        (let ([elm (car alist)])
     727                                (if (pair? elm)
     728                                        (let ([typ (car elm)]
     729                                                                [parent (and (pair? trail) (car trail))])
     730                                                (switch typ
     731                                                        ['test
     732                                                                (case parent
     733                                                                        [(test package case expect)
     734                                                                                (set! trail (cdr trail))
     735                                                                                (set! level (sub1 level))])]
     736                                                        ['package
     737                                                                (case parent
     738                                                                        [(test package)
     739                                                                                (set! level (add1 level))]
     740                                                                        [(case expect)
     741                                                                                (set! trail (cdr trail))
     742                                                                                (set! level (sub1 level))])]
     743                                                        ['case
     744                                                                (case parent
     745                                                                        [(test package)
     746                                                                                (set! level (add1 level))]
     747                                                                        [(case)
     748                                                                                (set! trail (cdr trail))]
     749                                                                        [(expect)
     750                                                                                (set! trail (cdr trail))
     751                                                                                (set! level (sub1 level))])]
     752                                                        ['expect
     753                                                                (case parent
     754                                                                        [(package case)
     755                                                                                (set! level (add1 level))]
     756                                                                        [(expect)
     757                                                                                (set! trail (cdr trail))])]
     758                                                        [else
     759                                                                (error 'walk-test-named-structure "unknown named structure element" elm)])
     760                                                (proc level typ (cdr elm))
     761                                                (loop (cdr alist) level (cons typ trail)) )
     762                                        (error 'walk-test-named-structure "unknown named structure element" elm) ) ) ) ) )
  • test-infrastructure/test-infrastructure-stat.scm

    r1701 r2551  
    1212;;;; Modifications Kon Lovett, Oct 15 2005
    1313
    14 (use syntax-case test-infrastructure-support test-infrastructure-runtime)
     14(use test-infrastructure-support test-infrastructure-runtime)
    1515
    1616(eval-when (compile)
     
    1818        (usual-integrations)
    1919                (inline)
    20                 (lambda-lift)
     20                (export ; Unused
     21                        stat-gloss-warnings-decr!
     22                        stat-todos-decr!
     23                        stat-equiv-expectation-warnings-decr!
     24                        stat-tol-expectation-warnings-decr!
     25                        stat-single-expectation-warnings-decr!
     26                        stat-all-expectation-warnings-decr!
     27                        stat-case-warnings-decr!
     28                        stat-package-warnings-decr!
     29                        stat-skip-warnings-ref
     30                        stat-todo-warnings-ref
     31                        stat-equiv-expectations-passed-set!
     32                        stat-tol-expectations-passed-set!
     33                        stat-single-expectations-passed-set!
     34                        stat-all-expectations-passed-set!
     35                        stat-cases-passed-set!
     36                        stat-packages-passed-set!
     37                        stat-terminations-set!
     38                        stat-equiv-expectations-set!
     39                        stat-tol-expectations-set!
     40                        stat-single-expectations-set!
     41                        stat-all-expectations-set!
     42                        stat-equiv-expectations-failed-decr!
     43                        stat-equiv-expectations-passed-decr!
     44                        stat-tol-expectations-failed-decr!
     45                        stat-tol-expectations-passed-decr!
     46                        stat-single-expectations-failed-decr!
     47                        stat-single-expectations-passed-decr!
     48                        stat-all-expectations-failed-decr!
     49                        stat-all-expectations-passed-decr!
     50                        stat-cases-terminated-decr!
     51                        stat-cases-failed-decr!
     52                        stat-cases-passed-decr!
     53                        stat-packages-terminated-decr!
     54                        stat-packages-failed-decr!
     55                        stat-packages-passed-decr!
     56                        stat-glosses-set!
     57                        stat-cases-set!
     58                        stat-packages-set!
     59                        stat-equiv-expectations-timing-incr!
     60                        stat-tol-expectations-timing-incr!
     61                        stat-single-expectations-timing-incr!
     62                        stat-all-expectations-timing-incr!
     63                        stat-cases-timing-incr!
     64                        stat-packages-timing-incr!
     65                        stat-todos-set!
     66                        stat-terminations-decr!
     67                        stat-equiv-expectations-decr!
     68                        stat-tol-expectations-decr!
     69                        stat-single-expectations-decr!
     70                        stat-all-expectations-decr!
     71                        stat-gloss-warnings-set!
     72                        stat-equiv-expectation-warnings-set!
     73                        stat-tol-expectation-warnings-set!
     74                        stat-single-expectation-warnings-set!
     75                        stat-all-expectation-warnings-set!
     76                        stat-case-warnings-set!
     77                        stat-package-warnings-set!
     78                        stat-glosses-decr!
     79                        stat-cases-decr!
     80                        stat-packages-decr!
     81                        stat-skips-decr!
     82                        stat-equiv-expectations-failed-set!
     83                        stat-tol-expectations-failed-set!
     84                        stat-single-expectations-failed-set!
     85                        stat-all-expectations-failed-set!
     86                        stat-cases-terminated-set!
     87                        stat-cases-failed-set!
     88                        stat-packages-terminated-set!
     89                        stat-packages-failed-set!
     90                        stat-equiv-expectations-timing-decr!
     91                        stat-tol-expectations-timing-decr!
     92                        stat-single-expectations-timing-decr!
     93                        stat-all-expectations-timing-decr!
     94                        stat-cases-timing-decr!
     95                        stat-packages-timing-decr!
     96                        stat-skips-set!
     97                        stat-cases-terminated-ref)
    2198    (export
    2299                        stat-packages-ref
     
    61138                        stat-compute-statistics)
    62139        )
    63 
    64         (cond-expand
    65                 [paranoia]
    66                 [else
    67                         (declare
    68                                 (no-procedure-checks)
    69                                 (no-argc-checks)
    70                                 (no-bound-checks))]
    71         )
    72140)
    73141
     
    90158;; a vector.
    91159
    92 (define-syntax test:gen-stat-API-func
    93         (syntax-rules (set! incr! decr! ref)
    94                 ((_ set! fname idx)
    95                         (define fname
    96                                 (lambda (statobj val)
    97                                         (vector-set! statobj idx val))))
    98                 ((_ incr! fname idx)
    99                         (define fname
    100                                 (lambda (statobj)
    101                                         (vector-set! statobj idx (+ (vector-ref statobj idx) 1)))))
    102                 ((_ decr! fname idx)
    103                         (define fname
    104                                 (lambda (statobj)
    105                                         (vector-set! statobj idx (- (vector-ref statobj idx) 1)))))
    106                 ((_ ref fname idx)
    107                         (define fname
    108                                 (lambda (statobj)
    109                                         (vector-ref statobj idx))))))
     160(define-macro (test:gen-stat-API-func OPER NAME IDX)
     161        (let ([FNAME (string->symbol (conc "stat-" NAME #\- OPER))])
     162                (switch OPER
     163                        ['set!
     164                                `(define (,FNAME statobj val)
     165                                                (vector-set! statobj ,IDX val))]
     166                        ['incr!
     167                                `(define (,FNAME statobj)
     168                                                (vector-set! statobj ,IDX (+ (vector-ref statobj ,IDX) 1)))]
     169                        ['decr!
     170                                `(define (,FNAME statobj)
     171                                                (vector-set! statobj ,IDX (- (vector-ref statobj ,IDX) 1)))]
     172                        ['ref
     173                                `(define (,FNAME statobj)
     174                                                (vector-ref statobj ,IDX))]) ) )
    110175
    111176(define-macro (test:gen-stat-API-oper NAME OPER IDX)
    112         `(test:gen-stat-API-func ,OPER ,(string->symbol (conc "stat-" NAME #\- OPER)) ,IDX))
     177        `(test:gen-stat-API-func ,OPER ,NAME ,IDX))
    113178
    114179(define-macro (test:gen-stat-API-suite NAME IDX)
  • test-infrastructure/test-infrastructure-support.scm

    r1977 r2551  
    1212;;;; Modifications Kon Lovett, Oct 15 2005
    1313
    14 (use syntax-case srfi-1 srfi-9 srfi-69 test-infrastructure-runtime test-infrastructure-timing)
     14(use srfi-1 srfi-9 srfi-69 test-infrastructure-state test-infrastructure-runtime)
    1515
    1616(eval-when (compile)
     
    1919        (fixnum)
    2020                (inline)
    21                 (lambda-lift)
    2221        (bound-to-procedure
    23                         ignore-result?
    2422                        test:strip-ignored-results)
    2523    (export
    26                 test:do-test-case-continue? test:do-test-case-continue-set!
    27                         test:undefined-value
    28                         test:test-case-body test:test-package-body
     24                        test:test-case-finalize
     25                        test:test-package-finalize
    2926                        test:test-case-clause-cont-result?
    30                         test:make-destructor test:make-ignore-result
     27                        test:make-destructor
    3128                        test:_expect-equiv-predicate
    3229                        test:_expect-predicate test:_expect-zero test:_expect-nonzero
     
    3734                        test:_expect-values-eq test:_expect-values-eqv test:_expect-values-equal
    3835                        test:_expect-exception
     36                        test:eval-mode?
    3937                        test:skip-test test:clear-skip-tests
    4038                        test:take-test test:clear-take-tests
    41                         test:capture-test-names
    42                         test:perform-test?)
    43         )
    44 
    45         (cond-expand
    46                 [paranoia]
    47                 [else
    48                         (declare
    49                                 (no-procedure-checks)
    50                                 (no-argc-checks)
    51                                 (no-bound-checks))]
     39                        test:clear-tests
     40                        test:capture-test-elements
     41                        test:capture-test-elements*
     42                        test:perform-test?
     43                        test-named-structure)
    5244        )
    5345)
    5446
    5547;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    56 ;; Abort or continue upon error in a test-case
    57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    58 
    59 (define test:do-test-case-continue? #f)
    60 
    61 (define (test:do-test-case-continue-set! flag)
    62         (set! test:do-test-case-continue? flag) )
    63 
    64 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    6548;;
    6649;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    6750
    68 (define test:undefined-value (void))
     51(define (test:test-case-finalize state cname dtor result . warnobj)
     52        ; Turn off timing after body eval'ed
     53        (test:timing-set! state #f)
     54        ; Call the destructor to get rid of anything the user didn't want
     55        (destructor-activate! dtor)
     56        ; If the user exited via the terminate mechanism, then record this
     57        ; fact with a real terminate node in the tree.
     58        (let ([stripped-result
     59                                        (if (user-termination? result)
     60                                                (list (test:make-terminate-result state #f cname 'test-case result))
     61                                                (test:strip-ignored-results result))])
     62                ; Return the typed list for this kind of test result
     63                (apply test:make-test-case-result state (all-testcase-expectations-true? stripped-result) cname stripped-result warnobj) ) )
    6964
    7065;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    7267;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    7368
    74 (define (test:test-case-body tname destname result . warnobj)
     69(define (test:test-package-finalize state pname dtor result . warnobj)
     70        ; Turn off timing after body eval'ed
     71        (test:timing-set! state #f)
    7572        ; Call the destructor to get rid of anything the user didn't want
    76         (destructor-activate! destname)
    77         (let ([stripped-test-result (test:strip-ignored-results result)])
    78                 ; If the user exited via the terminate mechanism, then record this
    79                 ; fact with a real terminate node in the tree.
    80                 (when (terminate? stripped-test-result)
    81                         (set! stripped-test-result
    82                                 (list (test:make-terminate-result #f tname 'test-case stripped-test-result))))
     73        (destructor-activate! dtor)
     74        ; If the user exited via the terminate mechanism, then record this
     75        ; fact with a real terminate node in the tree.
     76        (let ([stripped-result
     77                                        (if (user-termination? result)
     78                                                (list (test:make-terminate-result state #f pname 'test-package result))
     79                                                (test:strip-ignored-results result))])         
    8380                ; Return the typed list for this kind of test result
    84                 (let* ([expt (all-testcase-expectations-true? stripped-test-result)]
    85                                          [tcr (apply test:make-test-case-result expt tname stripped-test-result warnobj)])
    86                         ; Turn off timing after results eval'ed
    87                         (test:do-timing-set! #f)
    88                         tcr ) ) )
    89 
    90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    91 ;;
    92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    93 
    94 (define (test:test-package-body pname destname result . warnobj)
    95         ; Turn off timing after body eval'ed
    96         (test:do-timing-set! #f)
    97         ; Call the destructor to get rid of anything the user didn't want
    98         (destructor-activate! destname)
    99         (let ([stripped-test-result (test:strip-ignored-results result)])
    100                 ; If the user exited via the terminate mechanism, then record this
    101                 ; fact with a real terminate node in the tree.
    102                 (when (terminate? stripped-test-result)
    103                         (set! stripped-test-result
    104                                 (list (test:make-terminate-result #f pname 'test-package stripped-test-result))))
    105                 ; Return the typed list for this kind of test result
    106                 (let* ([expt (all-testpackage-results-true? stripped-test-result)]
    107                                          [tpr (apply test:make-test-package-result expt pname stripped-test-result warnobj)])
    108                         ; Turn off timing after results eval'ed
    109                         (test:do-timing-set! #f)
    110                         tpr ) ) )
     81                (apply test:make-test-package-result state (all-testpackage-results-true? stripped-result) pname stripped-result warnobj) ) )
    11182
    11283;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    12596;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    12697
    127 (define (test:make-destructor)
     98(define (test:make-destructor state)
    12899        (let ([q '()])
    129                 (lambda (message . args)
    130                         (switch message
     100                (lambda (operation . args)
     101                        (switch operation
    131102                         ['atexit
    132103                                (set! q (append q (list args)))
    133                                 (test:make-ignore-result)]
     104                                (test:make-ignore-result state)]
    134105                         ['activate
    135106                                (for-each
     
    140111                                         q)
    141112                                (set! q '())
    142                                 (test:make-ignore-result)]
     113                                (test:make-ignore-result state)]
    143114                         ['clear
    144115                                (set! q '())
    145                                 (test:make-ignore-result)]
     116                                (test:make-ignore-result state)]
    146117                         ['dump
    147118                                (let loop ([q q])
     
    150121                                                (newline)
    151122                                                (loop (cdr q))))
    152                                 (test:make-ignore-result)]
     123                                (test:make-ignore-result state)]
    153124                         [else
    154                                 (warning "unrecognized destructor message" message)
    155                                 (test:make-ignore-result)]))))
     125                                (warning "unrecognized destructor operation" operation)
     126                                (test:make-ignore-result state)]))))
    156127
    157128;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    178149
    179150;;;;;;;;;;;;;;;;;;
    180 ;; make a result type that is "ignored". This takes care of things like
    181 ;; using the destructor object in a sequence of expectations.
    182 ;;;;;;;;;;;;;;;;;;
    183 
    184 (define-record-type test:ignore-result
    185         (test:make-ignore-result)
    186         ignore-result?
    187 )
    188 
    189 ;;;;;;;;;;;;;;;;;;
    190151;; test-case-clause-cont-result?
    191152;; Is the value a successful expect result,
     
    193154;;;;;;;;;;;;;;;;;;
    194155
    195 (define (test:test-case-clause-cont-result? v)
     156(define (test:test-case-clause-cont-result? state v)
    196157        (or
    197158
    198159                ;Continue anyway?
    199                 test:do-test-case-continue?
     160                (test:case-continue? state)
    200161
    201162                ;FIXME There might be a better way to do this check for
     
    375336;;
    376337
    377 (define *perform-test-mode* 'always)
    378 (define *test-names* '())
    379 (define *test-name-table* #f)
    380 
    381 (define (test:capture-test-name typ msg)
    382         (set! *test-names* (alist-cons typ msg *test-names*)))
    383 
    384 (define (test:report-test flag)
     338(define (test:report-test state flag)
    385339        (if flag
    386340                (begin
    387                         (set! *perform-test-mode* 'report)
    388                         (set! *test-names* '()))
     341                        (test:mode-set! state 'report)
     342                        (test:element-names-set! state '()))
    389343                (begin
    390                         (set! *perform-test-mode* 'always)
    391                         (reverse! *test-names*))) )
    392 
    393 (define (test:add-test-name msgs)
    394         (unless *test-name-table*
    395                 (set! *test-name-table* (make-hash-table)))
     344                        (test:mode-set! state 'eval)
     345                        (test:element-names-set! state (reverse! (test:element-names state)))) ) )
     346
     347(define (test:add-elem-name state msgs)
     348        (unless (test:active-names state)
     349                (test:active-names-set! state (make-hash-table)))
    396350        (for-each
    397                 (cut hash-table-set! *test-name-table* <> #t)
     351                (cut hash-table-set! (test:active-names state) <> #t)
    398352                msgs) )
    399353
    400 (define (test:has-test-name? msg)
     354(define (test:has-elem-name? state msg)
    401355        ; Named item?
    402356        (if msg
    403357                        ;then lookup in table
    404                 (and *test-name-table* (hash-table-exists? *test-name-table* msg))
     358                (and (test:active-names state) (hash-table-exists? (test:active-names state) msg))
    405359                        ;else always 'take' unnamed items
    406                 (eq? 'take *perform-test-mode*) ) )
    407 
    408 (define (test:skip-test . rest)
    409         (set! *perform-test-mode* 'skip)
    410   (test:add-test-name rest))
    411 
    412 (define (test:clear-skip-tests)
    413         (set! *test-name-table* #f)
    414         (set! *perform-test-mode* 'always))
    415 
    416 (define (test:take-test . rest)
    417         (set! *perform-test-mode* 'take)
    418   (test:add-test-name rest))
    419 
    420 (define (test:clear-take-tests)
    421         (set! *test-name-table* #f)
    422         (set! *perform-test-mode* 'always))
    423 
    424 ;;
    425 
    426 (define (test:capture-test-names thunks names)
    427         (test:report-test #t)
    428         (let loop ([thunks thunks] [names names])
    429                 (unless (null? thunks)
    430                         (test:capture-test-name 'thunk (car names))
    431                         ((car thunks))
    432                         (loop (cdr thunks) (cdr names))) )
    433         (test:report-test #f) )
    434 
    435 (define (test:perform-test? typ msg)
    436         (switch *perform-test-mode*
    437                 ['always
    438                         #t]
     360                (eq? 'take (test:mode state)) ) )
     361
     362(define (test:capture-test-element-name state typ msg)
     363        (test:element-names-set! state (alist-cons typ msg (test:element-names state))))
     364
     365;;;
     366
     367(define (test:eval-mode? state)
     368        (not (eq? 'report (test:mode state))) )
     369
     370(define (test:skip-test test-proc . rest)
     371        (let ([state (test-proc 'state)])
     372                (test:mode-set! state 'skip)
     373                (test:add-elem-name state rest) ) )
     374
     375(define (test:clear-skip-tests test-proc)
     376        (let ([state (test-proc 'state)])
     377                (test:active-names-set! state #f)
     378                (test:mode-set! state 'eval) ) )
     379
     380(define (test:take-test test-proc . rest)
     381        (let ([state (test-proc 'state)])
     382                (test:mode-set! state 'take)
     383                (test:add-elem-name state rest) ) )
     384
     385(define (test:clear-take-tests test-proc)
     386        (let ([state (test-proc 'state)])
     387                (test:active-names-set! state #f)
     388                (test:mode-set! state 'eval) ) )
     389
     390(define (test:clear-tests test-proc)
     391        (test:clear-take-tests test-proc)
     392        (test:clear-skip-tests test-proc) )
     393
     394(define (test:capture-test-elements state proc name)
     395        (test:report-test state #t)
     396        (test:capture-test-element-name state 'test name)
     397        (proc)
     398        (test:report-test state #f) )
     399
     400(define (test:capture-test-elements* test-procs)
     401        (unless (null? test-procs)
     402                (let* ([test-proc (car test-procs)]
     403                                         [state (test-proc 'state)])
     404                        (test:capture-test-elements state test-proc (test:name state)))
     405                (test:capture-test-elements* (cdr test-procs)) ) )
     406
     407(define (test:perform-test? state typ msg)
     408        (switch (test:mode state)
    439409                ['report
    440                         (test:capture-test-name typ msg)
     410                        (test:capture-test-element-name state typ msg)
    441411                        (switch typ
    442412                                ['package #t]
     
    445415                                [else
    446416                                        (error 'test:perform-test? "bad test structure" typ)])]
     417                ['eval
     418                        #t]
     419                ['take
     420                        (test:has-elem-name? state msg)]
     421                ['skip
     422                        (not (test:has-elem-name? state msg))]
    447423                [else
    448                         (let ([flag (test:has-test-name? msg)])
    449                                 (switch *perform-test-mode*
    450                                         ['take flag]
    451                                         ['skip (not flag)]
    452                                         [else
    453                                                 (error 'test:perform-test? "bad test perform mode" *perform-test-mode*)]) )]) )
     424                        (error 'test:perform-test? "bad test perform mode" (test:mode state))] ) )
     425
     426;;;
     427
     428(define (test-named-structure . test-procs)
     429        (test:capture-test-elements* test-procs)
     430        (let loop ([test-procs test-procs]
     431                                                 [lst '()])
     432                (if (null? test-procs)
     433                        lst
     434                        (loop (cdr test-procs)
     435                                                (append lst (list-copy (test-element-names (car test-procs))))) ) ) )
  • test-infrastructure/test-infrastructure-test.scm

    r1701 r2551  
    11;;;; test-infrastructure-test.scm
    22
    3 (use syntax-case #;srfi-12 srfi-42 test-infrastructure miscmacros)
     3(use test-infrastructure)
     4(use srfi-42 miscmacros)
    45
    56(define (display-header . strs)
    67        (let ([hdr (apply conc strs)])
    78                (print hdr)
    8                 (let loop ([n (string-length hdr)])
    9                         (if (zero? n)
    10                                 (newline)
    11                                 (begin
    12                                         (display #\-)
    13                                         (loop (sub1 n)))) ) ) )
    14 
    15 (define (display-test-named-structure alist)
     9                (repeat (string-length hdr) (display #\-))
     10                (newline) ) )
     11
     12(define (display-test-named-structure elems)
    1613        (walk-test-named-structure
    1714                (lambda (level typ info)
     
    1916                                        [msg
    2017                                                (switch typ
    21                                                         ['thunk "Structure Of"]
     18                                                        ['test "Test"]
    2219                                                        ['package "Package"]
    2320                                                        ['case "Case"]
     
    2522                                (test:display-indented-objects-newline (* 2 level)
    2623                                        (conc msg ": " (or info ""))) ) )
    27                 alist) )
    28 
    29 (define (test-test-infrastructure)
     24                elems) )
     25
     26(test-procedure test-test-infrastructure
    3027
    3128        (test-package "Test infrastructure" pd pe
     
    117114                )
    118115
    119                 (test-group "Group 1"
    120 
     116                (test-group any "Group 1"
    121117                        (expect "silly expect-false" (lambda (v) (not v)) #f)
    122118                        (expect-zero 0)
     
    138134                )
    139135
    140                 (test-group (
     136                (test-group #f (
    141137                                [exn1 (make-composite-condition
    142138                                                                (make-property-condition 'abc 'cbs "pbs")
     
    161157                )
    162158
    163                 (test-group "EC 1"
     159                (test-group every "EC 1"
    164160                        (expect-ec (: e 100) (:let x (expt 2.0 e)) (positive? (expt 2 e)) => #t)
    165161                        (expect-ec "Fails (inexact only)" (: e 100) (:let x (expt 2.0 e)) (= (+ x 1) x) => #f)
     
    205201(newline)
    206202
    207 (display-header "Apply Skip" " " "Expectation Forms" " " "Group 1" " " "foo")
     203(display-header "Apply Skip" " " "\"Expectation Forms\"" " " "\"Group 1\"" " " "\"foo\"")
    208204(test-apply output-style-compact
    209205        (skip "Expectation Forms" "Group 1" "foo")
     
    211207(newline)
    212208
    213 (display-header "Apply Take" " " "Test infrastructure" " " "Expectation Forms" " " "Group 1" " " "foo")
     209(display-header "Apply Take" " " "\"Test infrastructure\"" " " "\"Expectation Forms\"" " " "\"Group 1\"" " " "\"foo\"")
    214210(test-apply output-style-compact
    215211        (take "Test infrastructure" "Expectation Forms") (take "Group 1" "foo")
  • test-infrastructure/test-infrastructure.html

    r1977 r2551  
    1515<h3>Version</h3>
    1616<ul>
     17<li>2.0 Incompatible Changes - thread safety, needs 'test-procedure' form [Kon Lovett]</li>
    1718<li>1.92 'expect-*' timing, see 'test-timing?' macro [Kon Lovett]</li>
    1819<li>1.91 Helper macros, some testeez-like forms [Kon Lovett]</li>
     
    6465same - <code>#f</code>.</p>
    6566
    66 <p><b>The Immediate Test Macro API</b></p>
     67<p><b>The Immediate Test Macro</b></p>
    6768
    6869<p>This macro will evaluate in a left to right fashion the clauses
     
    8788</dl>
    8889
    89 <p><b>The Quick Test Macro API</b></p>
     90<p><b>The Test Apply Macro</b></p>
    9091
    9192<p>This macro will execute the test procedure and send the results to a
     
    9394test packages, groups, cases, and expectations.</p>
    9495
    95 <p>Do not de-select all, or omit to select least one, test
    96 packages or groups. Otherwise the result will be ill-formed.</p>
    97 
    9896<p>The results are not kept.</p>
    9997
     
    10199<dt><em>(macro)</em><code> test-apply</code></dt>
    102100<dd><br />
    103 (test-apply [STYLER] [SPECIFIER ...] THUNK)
     101(test-apply [STYLER] [SPECIFIER ...] TEST-PROCEDURE)
    104102<br /></dd>
    105103<dd>
     
    114112selected. Unnamed elements are always performed. Also, <code>(skip CLAUSE ...)</code> forms,
    115113see below, still apply.</li>
    116 <li><code>THUNK</code> is a zero argument procedure returning a test
     114<li><code>TEST-PROCEDURE</code> is a zero argument procedure returning a test
    117115result object.</li>
    118116</ul>
     
    125123
    126124<dl>
    127 <dt><em>(macro)</em><code> test-named-structure</code></dt>
    128 <dd><br />
    129 (test-named-structure THUNK ...)
    130 <br /></dd>
    131 <dd>
    132 <ul>
    133 <li><code>THUNK</code> is a zero argument procedure returning a test
     125<dt><em>(procedure)</em><code> test-named-structure</code></dt>
     126<dd><br />
     127(test-named-structure TEST-PROCEDURE ...)
     128<br /></dd>
     129<dd>
     130<ul>
     131<li><code>TEST-PROCEDURE</code> is a zero argument procedure returning a test
    134132result object.</li>
    135133<li>This macro will walk the test procedure(s), only capturing the type and
    136134message of each test element. An association list is returned where the
    137 key is the element type (<code>thunk</code>, <code>package</code>,
     135key is the element type (<code>test</code>, <code>package</code>,
    138136<code>case</code>, <code>expect</code>) and the value is the message
    139137(which will be <code>#f</code> when the element is not named). The
    140 <code>thunk</code> element value is the symbolic form of the
    141 <code>THUNK</code>.</li>
    142 <li>It is best if the <code>THUNK</code> argument is a procedure variable,
     138<code>test</code> element value is the symbolic form of the
     139<code>TEST-PROCEDURE</code>.</li>
     140<li>It is best if the <code>TEST-PROCEDURE</code> argument is a procedure variable,
    143141and not a procedure object.</li>
    144142<li>The association list is a pre-order of the test hierarchy.</li>
     
    150148<dt><em>(procedure)</em><code> walk-test-named-structure</code></dt>
    151149<dd><br />
    152 (walk-test-named-structure PROCEDURE NAMED-STRUCTURE)
    153 <br /></dd>
    154 <dd>
    155 <ul>
    156 <li><code>PROCEDURE</code> is a three argument procedure. The first argument
     150(walk-test-named-structure WALKER NAMED-STRUCTURE)
     151<br /></dd>
     152<dd>
     153<ul>
     154<li><code>WALKER</code> is a three argument procedure. The first argument
    157155is the hierarchy level, counting up from 0. The second argument is the
    158156type of the test element, as above. The third argument is the name of the
    159157test element.</li>
    160158<li>This procedure will enumerate the <code>NAMED-STRUCTURE</code> association list,
    161 invoking the <code>PROCEDURE</code> for each element. The hierarchy level value
     159invoking the <code>WALKER</code> for each element. The hierarchy level value
    162160is the tree depth at the point of call.</li>
    163161</ul>
     
    165163</dl>
    166164
    167 <p><b>The Simple Test Package Macro API</b></p>
    168 
    169 <p>This macro will evaluate in a left to right fashion the clauses
    170 inside it. Clauses can only be certain things, detailed below. All of
    171 the clauses are executed, except of course if you bail out of the test
    172 group with the escape procedure mechanism. Note that a test group is a
    173 test package.</p>
    174 
    175 <p>The destructor object name is <code>destructor</code>. The escape procedure name
    176 is <code>escape</code>. Each nesting will lexically shadow the previous such
    177 definitions of an outer test group.</p>
    178 
    179 <dl>
    180 <dt><em>(macro)</em><code> test-group</code></dt>
    181 <dd><br />
    182 (test-group [MESSAGE] [(BINDINGS)] CLAUSES)
    183 <br /></dd>
    184 <dd>
    185 <ul>
    186 <li><code>MESSAGE</code> can be any scheme object, though usually it is a string.</li>
    187 <li><code>BINDINGS</code> are let-style bindings that you may create and exist in
    188 the lexical scope of the test package.</li>
    189 <li><code>CLAUSES</code> are uses of <code>(test-group ...)</code>,
    190 <code>(test-package ...)</code>, <code>(test-case ...)</code>,
    191 <code>(expect* ...)</code> along with <code>(gloss ...)</code>,
    192 <code>(todo ...)</code>, <code>(skip ...)</code>, and <code>(terminate
    193 ...)</code> macros. If the expectation fails, the test group macro will
    194 continue evaluating until all clauses are evaluated or the escape
    195 procedure mechanism is activated. This is different than a test-case
    196 macro where upon discovery of a failed expectation, evaluation stops
    197 immediately.</li>
    198 </ul>
    199 </dd>
    200 </dl>
    201 
    202 <p><b>The Test Package Macro API</b></p>
    203 
    204 <p>This macro will evaluate in a left to right fashion the clauses
    205 inside it. Clauses can only be certain things, detailed below. All of
    206 the clauses are executed, except of course if you bail out of the test
    207 package with the escape procedure mechanism. Test groups and packages
    208 may nest indefinitely.</p>
     165<p><b>The Test Procedure API</b></p>
     166
     167<dl>
     168<dt><em>(macro)</em><code> test-procedure</code></dt>
     169<dd><br />
     170(test-procedure NAME CLAUSE ...)
     171<br /></dd>
     172<dd>
     173<ul>
     174<li><code>NAME</code> is a symbol, the name of the newly defined test procedure.</li>
     175<li><code>CLAUSE</code> is any of the test API elements.</li>
     176<li><code>DESTNAME</code> is <code>test-destructor</code>.</li>
     177<li><code>TERMNAME</code> is <code>test-escape</code>.</li>
     178<li>Defines a variable, NAME, with a procedure value. The body of the test procedure is
     179wrapped in an anonymous <code>test-package</code>.</li>
     180</ul>
     181</dd>
     182</dl>
     183
     184<dl>
     185<dt><em>(procedure)</em><code> test-name</code></dt>
     186<dd><br />
     187(test-name TEST-PROCEDURE)
     188<br /></dd>
     189<dd>
     190<ul>
     191<li>Returns the symbolic name of the test procedure.</li>
     192</ul>
     193</dd>
     194</dl>
     195
     196<p><b>The Test Grouping API</b></p>
    209197
    210198<dl>
     
    235223<code>(test-package ...)</code>, <code>(test-case ...)</code> macros
    236224along with <code>(gloss ...)</code>, <code>(todo ...)</code>,
    237 <code>(skip ...)</code>, and <code>(terminate ...)</code> macros. While
    238 you may use the <code>(expect* ...)</code> style macros directly in a
     225<code>(skip ...)</code>, and <code>(terminate ...)</code> macros.
     226The clauses are evaluated in a left to right fashion.
     227<p>While you may use the <code>(expect* ...)</code> style macros directly in a
    239228test package, doing so is not recommended. If the expectation fails, the
    240229test package macro will continue evaluating until all clauses are
    241230evaluated or the escape procedure mechanism is activated. This is
    242231different than a test-case macro where upon discovery of a failed
    243 expectation, evaluation stops immediately.</li>
    244 </ul>
    245 </dd>
    246 </dl>
    247 
    248 <p><b>The Test Case Macro API</b></p>
    249 
    250 <p>This macro will evaluate in a left to right fashion the clauses inside
    251 it, <em>stopping at the first failed expectation</em>. Clauses can only
    252 be certain things as detailed below. You may also stop the execution of
    253 expectations if you bail out of the test case with the escape procedure
    254 mechanism. Test cases may <em>NOT</em> nest.</p>
     232expectation, evaluation stops immediately.</p></li>
     233</ul>
     234</dd>
     235</dl>
    255236
    256237<dl>
     
    278259<li><code>BINDINGS</code> are let-style bindings that you may create and exist in
    279260the lexical scope of the test case.</li>
    280 <li><code>CLAUSES</code> are uses of <code>(expect* ...)</code> macros
     261<li><code>CLAUSES</code> are uses of the <code>(expect* ...)</code> macros
    281262along with <code>(gloss ...)</code>, <code>(todo ...)</code>,
    282 <code>(skip ...)</code>, and <code>(terminate ...)</code> macros. It is
    283 important to note that upon discovery of a failed expectation,
     263<code>(skip ...)</code>, and <code>(terminate ...)</code> macros.
     264The clauses are evaluated in a left to right fashion.
     265<p>It is important to note that upon discovery of a failed expectation,
    284266the test case stops its evaluation and returns with the previous
    285267successful, and including the failed, expectations. This behavior can be
    286 changed using the <code>test-continue?</code> form. This behavior reverts to
    287 default at the start of each test-case.</li>
    288 </ul>
    289 </dd>
    290 </dl>
    291 
    292 <p><b>The Expectation Macro API</b></p>
     268changed using the <code>test-continue?</code> form. Reverts to
     269default at the start of each <code>test-case</code>.</p></li>
     270</ul>
     271</dd>
     272</dl>
     273
     274<dl>
     275<dt><em>(macro)</em><code> test-group</code></dt>
     276<dd><br />
     277(test-group [any | every] MESSAGE [(BINDINGS)] CLAUSES)
     278<br /></dd>
     279<dd>
     280<ul>
     281<li><code>any</code> will expand into a <code>test-package</code>.
     282This is the default.</li>
     283<li><code>every</code> will expand into a <code>test-case</code>.</li>
     284<li><code>DESTNAME</code> is <code>destructor</code>.</li>
     285<li><code>TERMNAME</code> is <code>escape</code>.</li>
     286<li><code>MESSAGE</code>, <code>BINDINGS</code>, <code>CLAUSES</code> are
     287as for <code>test-package</code> or <code>test-case</code>.</li>
     288</ul>
     289</dd>
     290</dl>
     291
     292<p><b>The Expectation API</b></p>
    293293
    294294<p>An expectation at its core simply evaluates its arguments and check to
     
    311311
    312312<dl>
     313
    313314<dt><em>(macro)</em><code> expect</code></dt>
    314315<dd><br />
     
    779780<dt><em>(macro)</em><code> expect-set!</code></dt>
    780781<dd><br />
    781 (expect-set! ID EXPR)
    782 <br /></dd>
    783 <dd>
    784 <ul>
    785 <li>Evaluates <code>EXPR</code> under an <code>expect-success</code>. When successful
    786 a <code>test:set!</code> is performed of the <code>EXPR</code> to <code>ID</code>.
    787 The <code>EXPR</code> is therefore evaluated <b>twice</b>.</li>
    788 </ul>
    789 </dd>
    790 
    791 <dt><em>(macro)</em><code> expect-successful-failure</code></dt>
    792 <dd><br />
    793 (expect-successful-failure EXPR)
    794 <br /></dd>
    795 <dd>
    796 <ul>
    797 <li>Same as <code>(expect-success "Failure" EXPR)</code>.</li>
    798 </ul>
    799 </dd>
    800 </dl>
    801 
    802 <p><b>Testeez-like API</b></p>
     782(expect-set! VAR EXPR)
     783<br /></dd>
     784<dd>
     785<ul>
     786<li>Evaluates <code>EXPR</code> as in <code>expect-success</code>. If successful the
     787<code>(set! VAR {result})</code> is performed.</li>
     788</ul>
     789</dd>
     790
     791</dl>
     792
     793<p><b>Testeez Synonym API</b></p>
    803794
    804795<p>
     
    810801
    811802<dl>
     803
     804<dt><em>(macro)</em><code> test-define</code></dt>
     805<dd><br />
     806(test-define [DESC] VAR EXPR CLAUSE ...)
     807<br /></dd>
     808<dd>
     809<ul>
     810<li>Defines <code>VAR</code>, in a new lexical scope, as the result of evaluating
     811<code>EXPR</code>.</li>
     812<li><code>CLAUSE</code> is as for <code>test-package</code>.</li>
     813</ul>
     814</dd>
     815
    812816<dt><em>(macro)</em><code> test/zero</code></dt>
    813817<dd><br />
     
    905909<br /><br /></dd>
    906910
    907 <dt><em>(macro)</em><code> test/ec</code></dt>
    908 <dd><br />
    909 (test/ec [DESC] QUALIFIER ... EXPECTED [=&gt; PRED] EXPR)
    910 <br /></dd>
    911 <dd>
    912 <ul>
    913 <li>Just a synonym. Cannot follow testeez argument order pattern.</li>
    914 </ul>
    915 </dd>
    916911</dl>
    917912
     
    15661561
    15671562<dl>
    1568 <dt><em>(procedure)</em><code> terminate</code></dt>
     1563<dt><em>(macro)</em><code> terminate</code></dt>
    15691564<dd><br />
    15701565(terminate TERMFUNC MESSAGE)
     
    22472242</pre>
    22482243
    2249 <p>The above example, when evaluated, will produce some human readable output
    2250 and the a <code>#t</code> value as the result of the top level package. The <code>result</code>
    2251 variable contains the tree of evaluated expectations, test cases, and the
    2252 package arranged in a hierarchy extremely similar to the nesting of the
    2253 above macros. If you desire to manipulate the result tree yourself, you
    2254 may use the various APIs to manipulate the various results. Please see the
    2255 implementation of <code>(output-style-human)</code> in the
    2256 test-infrastructure source to for an example of this.</p>
    2257 
    2258 <p>The variables: <code>pe</code>, <code>e</code> are the escape functions you may use with the
    2259 <code>(terminate)</code> procedure if you wish to abort the above code
    2260 somewhere.</p>
    2261 
    2262 <p>The variables: <code>pd</code>, <code>d</code> allow use of a "destructor" object which allows
    2263 you to run side effecting functions at the "finishing" point of the evaluation
    2264 of the test case or test package. These functions are run no matter if the code
    2265 succeeded correctly or not, so be careful to manage the destructor object
     2244<p>The above example, when evaluated, will produce some human readable
     2245output and the a <code>#t</code> value as the result of the top level
     2246package. The <code>result</code> variable contains the tree of evaluated
     2247expectations, test cases, and the package arranged in a hierarchy
     2248extremely similar to the nesting of the above macros. If you desire to
     2249manipulate the result tree yourself, you may use the various APIs to
     2250manipulate the various results. Please see the implementation of
     2251<code>(output-style-human)</code> in the test-infrastructure source to
     2252for an example of this.</p>
     2253
     2254<p>The variables: <code>pe</code>, <code>e</code> are the escape
     2255functions you may use with the <code>(terminate ...)</code> macro if
     2256you wish to abort the above code somewhere.</p>
     2257
     2258<p>The variables: <code>pd</code>, <code>d</code> allow use of a
     2259"destructor" object which allows you to run side effecting functions at
     2260the "finishing" point of the evaluation of the test case or test
     2261package. These functions are run no matter if the code succeeded
     2262correctly or not, so be careful to manage the destructor object
    22662263carefully so you don't perform unwanted side effects. The names of the
    22672264destructor objects you supply are lexically scoped in the bodies of the
    22682265test case or test package.</p>
    22692266
    2270 <p>Now, here is some example output that <code>(output-style-human)</code> might
    2271 generate with the above testing code:</p>
     2267<p>Now, here is some example output that
     2268<code>(output-style-human)</code> might generate with the above testing
     2269code:</p>
    22722270
    22732271<pre>
  • test-infrastructure/test-infrastructure.meta

    r1701 r2551  
    1414        "test-infrastructure-runtime.scm"
    1515        "test-infrastructure-fp.scm"
    16         "test-infrastructure-timing.scm"
     16        "test-infrastructure-state.scm"
    1717        "test-infrastructure-stat.scm"
    1818        "test-infrastructure-output.scm"
  • test-infrastructure/test-infrastructure.scm

    r1982 r2551  
    88;;;; to its stability or robustness is implied in any way. You may not hold me
    99;;;; or anyone else liable for any use of this source code. Please try to keep
    10 ;;;; this source code as close to R5RS(or later) scheme as possible. Thank you.
     10;;;; this source code as close to R5RS (or later) scheme as possible. Thank you.
    1111
    1212;;;; Modifications Kon Lovett, Oct 15 2005
     
    1414(use syntax-case)
    1515
    16 ;;; Naming convention:
     16;; Naming convention:
     17;;
     18;; - unevaluated: <uppercase abbreviation> - evaluated: <fullname>
     19;; ex: unevaluated: CLS - evaluated: clause
     20;;
     21;; - All private but exported symbols are prefixed w/ "test:"
     22
     23;; All exception handling per the withdrawn SRFI-12
     24
    1725;;;
    18 ;;; - unevaluated: <abbreviation> - evaluated: <fullname>
    19 ;;; ex: unevaluated: cls - evaluated: clause
    20 
    21 ;;; All exception handling uses srfi-12 (withdrawn)
     26;;; Toplevel Forms
     27;;;
     28
     29;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     30;; REPL quick test
     31;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     32
     33(define-syntax test:eval-test-it-body
     34  (syntax-rules ()
     35
     36        ;; Do NOT re-order!
     37
     38                [(_ STATE)
     39                        '()]
     40
     41                [(_ STATE (EXPR EXPT))
     42                        (list (test:expect-equal STATE '(EXPR EXPT) EXPT EXPR))]
     43
     44                [(_ STATE (EXPR EXPT) REST ...)
     45                        (cons
     46                                (test:expect-equal STATE '(EXPR EXPT) EXPT EXPR)
     47                                (test:eval-test-it-body STATE REST ...))]
     48        ))
     49
     50(define-syntax (test-it X)
     51  (syntax-case X ()
     52                [(sk CLAUSES ...)
     53                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     54                                #'(let ([STATE (test:make-default-state)])
     55                                        (output-style-minimal (test:test-package-finalize STATE #f (test:make-destructor STATE) (test:eval-test-it-body STATE CLAUSES ...)))))]
     56        ))
     57
     58;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     59;; Perform & report form
     60;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     61
     62(define-syntax test:eval-specifiers
     63  (syntax-rules (skip take)
     64
     65        ;; Do NOT re-order!
     66
     67                [(_ TEST-PROC (skip MSG ...))
     68                        (test:skip-test TEST-PROC MSG ...)]
     69
     70                [(_ TEST-PROC (take MSG ...))
     71                        (test:take-test TEST-PROC MSG ...)]
     72
     73                [(_ TEST-PROC (skip MSG ...) REST ...)
     74                        (begin
     75                                (test:skip-test TEST-PROC MSG ...)
     76                                (test:eval-specifiers TEST-PROC REST ...))]
     77
     78                [(_ TEST-PROC (take MSG ...) REST ...)
     79                        (begin
     80                                (test:take-test TEST-PROC MSG ...)
     81                                (test:eval-specifiers TEST-PROC REST ...))]
     82
     83                [(_ TEST-PROC OTHER)
     84                        OTHER]
     85        ))
     86
     87(define-syntax test-apply
     88  (syntax-rules ()
     89
     90        ;; Do NOT re-order!
     91
     92                [(_ (NAME ...) ... TEST-PROC)
     93                        (test-apply output-style-minimal (NAME ...) ... TEST-PROC)]
     94
     95                [(_ STYLER TEST-PROC)
     96                        (STYLER (TEST-PROC))]
     97
     98                [(_ STYLER (NAME ...) ... TEST-PROC)
     99                        (dynamic-wind
     100                                (lambda ()
     101                                        (test:clear-tests TEST-PROC))
     102                                (lambda ()
     103                                        (test:eval-specifiers TEST-PROC (NAME ...) ...)
     104                                        (STYLER (TEST-PROC)))
     105                                (lambda ()
     106                                        (test:clear-tests TEST-PROC)))]
     107
     108                [(_ TEST-PROC)
     109                        (test-apply output-style-minimal TEST-PROC)]
     110        ))
     111
     112;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     113;; Define a Test Procedure
     114;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     115
     116(define-syntax (test-procedure X)
     117  (syntax-case X ()
     118
     119                [(sk NAME ((VAR VAL) ...) (FORMS ...) CLAUSES ...)
     120                        (identifier? #'NAME)
     121                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     122                                                                                [DTOR (datum->syntax-object #'sk 'test-destructor)]
     123                                                                                [ESCR (datum->syntax-object #'sk 'test-escape)])
     124                                #'(define NAME
     125                                        (let ([STATE (test:make-default-state 'NAME)])
     126                                                (lambda args
     127                                                        (if (null? args)
     128                                                                (let ([DTOR (test:make-destructor STATE)])
     129                                                                        (test:test-package-finalize STATE #f DTOR
     130                                                                                (call-with-current-continuation
     131                                                                                        (lambda (k)
     132                                                                                                (with-exception-handler
     133                                                                                                        (lambda (exn)
     134                                                                                                                (k (test:make-user-termination exn)))
     135                                                                                                        (lambda ()
     136                                                                                                                (let ((VAR VAL) ...)
     137                                                                                                                        FORMS ...
     138                                                                                                                        (call-with-current-continuation
     139                                                                                                                                (lambda (ESCR) (test:eval-lr CLAUSES ...))))))))))
     140                                                                (switch (car args)
     141                                                                        ['state
     142                                                                                STATE]
     143                                                                        ['reset
     144                                                                                (set! STATE (test:make-default-state 'NAME))]
     145                                                                        ['introspect
     146                                                                                (test:capture-test-elements STATE NAME 'NAME)]
     147                                                                        [else
     148                                                                                (error 'NAME "bad test arguments" args)]))))))]
     149
     150                [(sk NAME ((VAR VAL) ...) CLAUSES ...)
     151                        (identifier? #'NAME)
     152                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     153                                                                                [DTOR (datum->syntax-object #'sk 'test-destructor)]
     154                                                                                [ESCR (datum->syntax-object #'sk 'test-escape)])
     155                                #'(define NAME
     156                                        (let ([STATE (test:make-default-state 'NAME)])
     157                                                (lambda args
     158                                                        (if (null? args)
     159                                                                (let ([DTOR (test:make-destructor STATE)])
     160                                                                        (test:test-package-finalize STATE #f DTOR
     161                                                                                (call-with-current-continuation
     162                                                                                        (lambda (k)
     163                                                                                                (with-exception-handler
     164                                                                                                        (lambda (exn)
     165                                                                                                                (k (test:make-user-termination exn)))
     166                                                                                                        (lambda ()
     167                                                                                                                (let ((VAR VAL) ...)
     168                                                                                                                        (call-with-current-continuation
     169                                                                                                                                (lambda (ESCR) (test:eval-lr CLAUSES ...))))))))))
     170                                                                (switch (car args)
     171                                                                        ['state
     172                                                                                STATE]
     173                                                                        ['reset
     174                                                                                (set! STATE (test:make-default-state 'NAME))]
     175                                                                        ['introspect
     176                                                                                (test:capture-test-elements STATE NAME 'NAME)]
     177                                                                        [else
     178                                                                                (error 'NAME "bad test arguments" args)]))))))]
     179
     180                [(sk NAME (FORMS ...) CLAUSES ...)
     181                        (identifier? #'NAME)
     182                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     183                                                                                [DTOR (datum->syntax-object #'sk 'test-destructor)]
     184                                                                                [ESCR (datum->syntax-object #'sk 'test-escape)])
     185                                #'(define NAME
     186                                        (let ([STATE (test:make-default-state 'NAME)])
     187                                                (lambda args
     188                                                        (if (null? args)
     189                                                                (let ([DTOR (test:make-destructor STATE)])
     190                                                                        (test:test-package-finalize STATE #f DTOR
     191                                                                                (call-with-current-continuation
     192                                                                                        (lambda (k)
     193                                                                                                (with-exception-handler
     194                                                                                                        (lambda (exn)
     195                                                                                                                (k (test:make-user-termination exn)))
     196                                                                                                        (lambda ()
     197                                                                                                                FORMS ...
     198                                                                                                                (call-with-current-continuation
     199                                                                                                                        (lambda (ESCR) (test:eval-lr CLAUSES ...)))))))))
     200                                                                (switch (car args)
     201                                                                        ['state
     202                                                                                STATE]
     203                                                                        ['reset
     204                                                                                (set! STATE (test:make-default-state 'NAME))]
     205                                                                        ['introspect
     206                                                                                (test:capture-test-elements STATE NAME 'NAME)]
     207                                                                        [else
     208                                                                                (error 'NAME "bad test arguments" args)]))))))]
     209
     210                [(sk NAME CLAUSES ...)
     211                        (identifier? #'NAME)
     212                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     213                                                                                [DTOR (datum->syntax-object #'sk 'test-destructor)]
     214                                                                                [ESCR (datum->syntax-object #'sk 'test-escape)])
     215                                #'(define NAME
     216                                        (let ([STATE (test:make-default-state 'NAME)])
     217                                                (lambda args
     218                                                        (if (null? args)
     219                                                                (let ([DTOR (test:make-destructor STATE)])
     220                                                                        (test:test-package-finalize STATE #f DTOR
     221                                                                                (call-with-current-continuation
     222                                                                                        (lambda (k)
     223                                                                                                (with-exception-handler
     224                                                                                                        (lambda (exn)
     225                                                                                                                (k (test:make-user-termination exn)))
     226                                                                                                        (lambda ()
     227                                                                                                                (call-with-current-continuation
     228                                                                                                                        (lambda (ESCR) (test:eval-lr CLAUSES ...)))))))))
     229                                                                (switch (car args)
     230                                                                        ['state
     231                                                                                STATE]
     232                                                                        ['reset
     233                                                                                (set! STATE (test:make-default-state 'NAME))]
     234                                                                        ['introspect
     235                                                                                (test:capture-test-elements STATE NAME 'NAME)]
     236                                                                        [else
     237                                                                                (error 'NAME "bad test arguments" args)]))))))]
     238        ))
     239
     240;;;
     241;;; Internal Forms
     242;;;
    22243
    23244;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    27248(define-syntax test:perform-if
    28249  (syntax-rules ()
    29 
    30                 [(_ TYPE NAME EXPR)
    31                         (if (test:perform-test? TYPE NAME)
    32                                 EXPR
    33                                 (test:make-skip-result NAME))]
    34         ))
    35 
    36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    37 ;; Perform & report form
    38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    39 
    40 (define-syntax test:eval-specifiers
    41   (syntax-rules (skip take)
    42 
    43         ;; Do NOT re-order!
    44 
    45                 [(_ (skip MSG ...))
    46                         (test:skip-test MSG ...)]
    47 
    48                 [(_ (take MSG ...))
    49                         (test:take-test MSG ...)]
    50 
    51                 [(_ (skip MSG ...) REST ...)
    52                         (begin (test:skip-test MSG ...) (test:eval-specifiers REST ...))]
    53 
    54                 [(_ (take MSG ...) REST ...)
    55                         (begin (test:take-test MSG ...) (test:eval-specifiers REST ...))]
    56 
    57                 [(_ OTHER)
    58                         OTHER]
    59         ))
    60 
    61 (define-syntax test-apply
    62   (syntax-rules ()
    63 
    64         ;; Do NOT re-order!
    65 
    66                 [(_ (NAME ...) ... THUNK)
    67                         (test-apply output-style-minimal (NAME ...) ... THUNK)]
    68 
    69                 [(_ STYLER THUNK)
    70                         (STYLER (THUNK))]
    71 
    72                 [(_ STYLER (NAME ...) ... THUNK)
    73                         (dynamic-wind
    74                                 (lambda ()
    75                                         (test:clear-skip-tests) (test:clear-take-tests))
    76                                 (lambda ()
    77                                         (test:eval-specifiers (NAME ...) ...)
    78                                         (STYLER (THUNK)))
    79                                 (lambda ()
    80                                         (test:clear-skip-tests) (test:clear-take-tests)))]
    81 
    82                 [(_ THUNK)
    83                         (test-apply output-style-minimal THUNK)]
    84         ))
    85 
    86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    87 ;; Get test suite structure
    88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    89 
    90 (define-syntax test-named-structure
    91   (syntax-rules ()
    92         [(_ THUNK ...)
    93                 (test:capture-test-names (list THUNK ...) (list 'THUNK ...))]
    94         ))
    95 
    96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    97 ;; REPL quick test
    98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    99 
    100 (define-syntax test:eval-test-it-body
    101   (syntax-rules ()
    102 
    103         ;; Do NOT re-order!
    104 
    105                 [(_ (EXPR EXPT))
    106                         (list (expect-equal '(EXPR EXPT) EXPT EXPR))]
    107 
    108                 [(_ (EXPR EXPT) REST ...)
    109                         (cons (expect-equal '(EXPR EXPT) EXPT EXPR)
    110                                 (test:eval-test-it-body REST ...))]
    111         ))
    112 
    113 (define-syntax test-it
    114   (syntax-rules ()
    115                 [(_ REST ...)
    116                         (output-style-minimal
    117                                 (test:test-package-body #f (test:make-destructor)
    118                                         (test:eval-test-it-body REST ...)))]
    119         ))
    120 
    121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    122 ;; Shortform test-package
    123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    124 
    125 (define-syntax test-group
    126   (syntax-rules ()
    127 
    128         ;; Do NOT re-order!
    129 
    130                 [(_ MSG ((NAME VALUE) ...) CLAUSE ...)
    131                         (test-package MSG destructor escape ((NAME VALUE) ...) CLAUSE ...)]
    132 
    133                 [(_ ((NAME VALUE) ...) CLAUSE ...)
    134                         (test-group #f ((NAME VALUE) ...) CLAUSE ...)]
    135 
    136                 [(_ MSG CLAUSE ...)
    137                         (test-package MSG destructor escape CLAUSE ...)]
    138 
    139                 [(_ CLAUSE ...)
    140                         (test-group #f CLAUSE ...)]
    141         ))
     250                [(_ STATE TYPE NAME CLAUSE)
     251                        (if (test:perform-test? STATE TYPE NAME)
     252                                CLAUSE
     253                                (test:make-skip-result STATE NAME))]))
    142254
    143255;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    171283  (syntax-rules ()
    172284
    173                 [(_ exp)
    174                         (list exp)]
    175 
    176                 [(_ exp-head exp-tail ...)
    177                         (let ([head exp-head]) ;; evaluate exp-head right here!
    178                                 (if (test:test-case-clause-cont-result? head)
    179                                                 ;then only continue evaluating down the list if the expectation
    180                                                 ;turned out to be true
    181                                         (cons head (test:eval-expectations exp-tail ...))
    182                                                 ;else save the first false one in the master list
     285                [(_ STATE)
     286                        '()]
     287
     288                [(_ STATE EXP)
     289                        (list EXP)]
     290
     291                [(_ STATE EXP-HEAD EXP-TAIL ...)
     292                        (let ([head EXP-HEAD])
     293                                (if (test:test-case-clause-cont-result? STATE head)
     294                                        (cons head (test:eval-expectations STATE EXP-TAIL ...))
    183295                                        (list head)))]
    184296        ))
    185297
    186 (define-syntax test-case
     298(define-syntax test:test-case
    187299  (syntax-rules (warn)
    188300
    189301        ;; Do NOT re-order!
    190302
    191                 ;Support the optional let bindings with warning syntax
    192     [(_ testname destname escape (warn warning) ((name value) ...) clauses ...)
    193         (test:perform-if 'case testname
    194                                 (let ((name value) ...)
    195                                         (let ([destname (test:make-destructor)])
    196                                                 (test:do-test-case-continue-set! #f)
    197                                                 (let ([test-result (call/cc (lambda (escape) (test:eval-expectations clauses ...)))])
    198                                                         (test:test-case-body testname destname test-result warning)))))]
    199 
    200                 ;Support the optional let bindings
    201     [(_ testname destname escape ((name value) ...) clauses ...)
    202         (test:perform-if 'case testname
    203                                 (let ((name value) ...)
    204                                         (let ([destname (test:make-destructor)])
    205                                                 (test:do-test-case-continue-set! #f)
    206                                                 (let ([test-result (call/cc (lambda (escape) (test:eval-expectations clauses ...)))])
    207                                                         (test:test-case-body testname destname test-result)))))]
    208 
    209                 ;No let bindings with warning syntax
    210     [(_ testname destname escape (warn warning) clauses ...)
    211         (test:perform-if 'case testname
    212                                 (let ([destname (test:make-destructor)])
    213                                         (test:do-test-case-continue-set! #f)
    214                                         (let ([test-result (call/cc (lambda (escape) (test:eval-expectations clauses ...)))])
    215                                                 (test:test-case-body testname destname test-result warning))))]
    216 
    217                 ;No let bindings or warning
    218     [(_ testname destname escape clauses ...)
    219         (test:perform-if 'case testname
    220                                 (let ([destname (test:make-destructor)])
    221                                         (test:do-test-case-continue-set! #f)
    222                                         (let ([test-result (call/cc (lambda (escape) (test:eval-expectations clauses ...)))])
    223                                                 (test:test-case-body testname destname test-result))))]
     303    [(_ STATE TESTNAME DESTNAME ESCNAME (warn WARNING) ((NAME VALUE) ...) CLAUSES ...)
     304                        (test:perform-if STATE 'case TESTNAME
     305                                (let ((NAME VALUE) ...)
     306                                        (let ([DESTNAME (test:make-destructor STATE)])
     307                                                (test:case-continue-set! STATE #f)
     308                                                (let ([test-result (call-with-current-continuation (lambda (ESCNAME) (test:eval-expectations STATE CLAUSES ...)))])
     309                                                        (test:test-case-finalize STATE TESTNAME DESTNAME test-result WARNING)))))]
     310
     311    [(_ STATE TESTNAME DESTNAME ESCNAME ((NAME VALUE) ...) CLAUSES ...)
     312                        (test:perform-if STATE 'case TESTNAME
     313                                (let ((NAME VALUE) ...)
     314                                        (let ([DESTNAME (test:make-destructor STATE)])
     315                                                (test:case-continue-set! STATE #f)
     316                                                (let ([test-result (call-with-current-continuation (lambda (ESCNAME) (test:eval-expectations STATE CLAUSES ...)))])
     317                                                        (test:test-case-finalize STATE TESTNAME DESTNAME test-result)))))]
     318
     319    [(_ STATE TESTNAME DESTNAME ESCNAME (warn WARNING) CLAUSES ...)
     320                        (test:perform-if STATE 'case TESTNAME
     321                                (let ([DESTNAME (test:make-destructor STATE)])
     322                                        (test:case-continue-set! STATE #f)
     323                                        (let ([test-result (call-with-current-continuation (lambda (ESCNAME) (test:eval-expectations STATE CLAUSES ...)))])
     324                                                (test:test-case-finalize STATE TESTNAME DESTNAME test-result WARNING))))]
     325
     326    [(_ STATE TESTNAME DESTNAME ESCNAME CLAUSES ...)
     327                        (test:perform-if STATE 'case TESTNAME
     328                                (let ([DESTNAME (test:make-destructor STATE)])
     329                                        (test:case-continue-set! STATE #f)
     330                                        (let ([test-result (call-with-current-continuation (lambda (ESCNAME) (test:eval-expectations STATE CLAUSES ...)))])
     331                                                (test:test-case-finalize STATE TESTNAME DESTNAME test-result))))]
     332        ))
     333
     334(define-syntax (test-case X)
     335  (syntax-case X (warn)
     336
     337        ;; Do NOT re-order!
     338
     339    [(sk TESTNAME DESTNAME ESCNAME (warn WARNING) ((NAME VALUE) ...) CLAUSES ...)
     340                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     341                                #'(test:test-case STATE TESTNAME DESTNAME ESCNAME (warn WARNING) ((NAME VALUE) ...) CLAUSES ...))]
     342
     343    [(sk TESTNAME DESTNAME ESCNAME ((NAME VALUE) ...) CLAUSES ...)
     344                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     345                                #'(test:test-case STATE TESTNAME DESTNAME ESCNAME ((NAME VALUE) ...) CLAUSES ...))]
     346
     347    [(sk TESTNAME DESTNAME ESCNAME (warn WARNING) CLAUSES ...)
     348                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     349                                #'(test:test-case STATE TESTNAME DESTNAME ESCNAME (warn WARNING) CLAUSES ...))]
     350
     351    [(sk TESTNAME DESTNAME ESCNAME CLAUSES ...)
     352                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     353                                #'(test:test-case STATE TESTNAME DESTNAME ESCNAME CLAUSES ...))]
    224354        ))
    225355
     
    255385        (syntax-rules ()
    256386
    257                 [(_ exp)
    258                         (list exp)]
    259 
    260                 ;Evaluate all forms
    261                 [(_ exp-head exp-tail ...)
    262                         (cons exp-head (test:eval-lr exp-tail ...))]
    263         ))
    264 
    265 (define-syntax test-package
     387                [(_)
     388                        '()]
     389
     390                [(_ EXP)
     391                        (list EXP)]
     392
     393                [(_ EXP-HEAD EXP-TAIL ...)
     394                        (cons EXP-HEAD (test:eval-lr EXP-TAIL ...))]
     395        ))
     396
     397(define-syntax test:test-package
    266398  (syntax-rules (warn)
    267399
    268400        ;; Do NOT re-order!
    269401
    270                 ;Support the optional let bindings with warning syntax
    271     [(_ packagename destname escape (warn warning) ((name value) ...) clauses ...)
    272         (test:perform-if 'package packagename
    273                                 (let ((name value) ...)
    274                                         (let ([destname (test:make-destructor)])
    275                                                 (let ([test-result (call/cc (lambda (escape) (test:eval-lr clauses ...)))])
    276                                                         (test:test-package-body packagename destname test-result warning)))))]
    277 
    278                 ;Support the optional let bindings
    279     [(_ packagename destname escape ((name value) ...) clauses ...)
    280         (test:perform-if 'package packagename
    281                                 (let ((name value) ...)
    282                                         (let ([destname (test:make-destructor)])
    283                                                 (let ([test-result (call/cc (lambda (escape) (test:eval-lr clauses ...)))])
    284                                                         (test:test-package-body packagename destname test-result)))))]
    285 
    286                 ;No let bindings with warning syntax
    287     [(_ packagename destname escape (warn warning) clauses ...)
    288         (test:perform-if 'package packagename
    289                                 (let ([destname (test:make-destructor)])
    290                                         (let ([test-result (call/cc (lambda (escape) (test:eval-lr clauses ...)))])
    291                                                 (test:test-package-body packagename destname test-result warning))))]
    292 
    293                 ;No let bindings or warning
    294     [(_ packagename destname escape clauses ...)
    295         (test:perform-if 'package packagename
    296                                 (let ([destname (test:make-destructor)])
    297                                         (let ([test-result (call/cc (lambda (escape) (test:eval-lr clauses ...)))])
    298                                                 (test:test-package-body packagename destname test-result))))]
     402    [(_ STATE TESTNAME DESTNAME ESCNAME (warn WARNING) ((NAME VALUE) ...) CLAUSES ...)
     403                        (test:perform-if STATE 'package TESTNAME
     404                                (let ((NAME VALUE) ...)
     405                                        (let ([DESTNAME (test:make-destructor STATE)])
     406                                                (let ([test-result (call-with-current-continuation (lambda (ESCNAME) (test:eval-lr CLAUSES ...)))])
     407                                                        (test:test-package-finalize STATE TESTNAME DESTNAME test-result WARNING)))))]
     408
     409    [(_ STATE TESTNAME DESTNAME ESCNAME ((NAME VALUE) ...) CLAUSES ...)
     410                        (test:perform-if STATE 'package TESTNAME
     411                                (let ((NAME VALUE) ...)
     412                                        (let ([DESTNAME (test:make-destructor STATE)])
     413                                                (let ([test-result (call-with-current-continuation (lambda (ESCNAME) (test:eval-lr CLAUSES ...)))])
     414                                                        (test:test-package-finalize STATE TESTNAME DESTNAME test-result)))))]
     415
     416    [(_ STATE TESTNAME DESTNAME ESCNAME (warn WARNING) CLAUSES ...)
     417                        (test:perform-if STATE 'package TESTNAME
     418                                (let ([DESTNAME (test:make-destructor STATE)])
     419                                        (let ([test-result (call-with-current-continuation (lambda (ESCNAME) (test:eval-lr CLAUSES ...)))])
     420                                                (test:test-package-finalize STATE TESTNAME DESTNAME test-result WARNING))))]
     421
     422    [(_ STATE TESTNAME DESTNAME ESCNAME CLAUSES ...)
     423                        (test:perform-if STATE 'package TESTNAME
     424                                (let ([DESTNAME (test:make-destructor STATE)])
     425                                        (let ([test-result (call-with-current-continuation (lambda (ESCNAME) (test:eval-lr CLAUSES ...)))])
     426                                                (test:test-package-finalize STATE TESTNAME DESTNAME test-result))))]
     427        ))
     428
     429(define-syntax (test-package X)
     430  (syntax-case X (warn)
     431
     432        ;; Do NOT re-order!
     433
     434    [(sk TESTNAME DESTNAME ESCNAME (warn WARNING) ((NAME VALUE) ...) CLAUSES ...)
     435                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     436                                #'(test:test-package STATE TESTNAME DESTNAME ESCNAME (warn WARNING) ((NAME VALUE) ...) CLAUSES ...))]
     437
     438    [(sk TESTNAME DESTNAME ESCNAME ((NAME VALUE) ...) CLAUSES ...)
     439                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     440                                #'(test:test-package STATE TESTNAME DESTNAME ESCNAME ((NAME VALUE) ...) CLAUSES ...))]
     441
     442    [(sk TESTNAME DESTNAME ESCNAME (warn WARNING) CLAUSES ...)
     443                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     444                                #'(test:test-package STATE TESTNAME DESTNAME ESCNAME (warn WARNING) CLAUSES ...))]
     445
     446    [(sk TESTNAME DESTNAME ESCNAME CLAUSES ...)
     447                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     448                                #'(test:test-package STATE TESTNAME DESTNAME ESCNAME CLAUSES ...))]
     449        ))
     450
     451;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     452;; test-group - short form of test-package & test-case w/ fixed
     453;; destructor & escape symbols.
     454;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     455
     456(define-syntax (test-group X)
     457  (syntax-case X (every any)
     458
     459        ;; Do NOT re-order!
     460
     461                [(sk any TESTNAME ((NAME VALUE) ...) CLAUSES ...)
     462                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     463                                                                                [DTOR (datum->syntax-object #'sk 'destructor)]
     464                                                                                [ESCR (datum->syntax-object #'sk 'escape)])
     465                                #'(test:test-package STATE TESTNAME DTOR ESCR ((NAME VALUE) ...) CLAUSES ...))]
     466
     467                [(sk any TESTNAME CLAUSES ...)
     468                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     469                                                                                [DTOR (datum->syntax-object #'sk 'destructor)]
     470                                                                                [ESCR (datum->syntax-object #'sk 'escape)])
     471                                #'(test:test-package STATE TESTNAME DTOR ESCR CLAUSES ...))]
     472
     473                [(sk every TESTNAME ((NAME VALUE) ...) CLAUSES ...)
     474                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     475                                                                                [DTOR (datum->syntax-object #'sk 'destructor)]
     476                                                                                [ESCR (datum->syntax-object #'sk 'escape)])
     477                                #'(test:test-case STATE TESTNAME DTOR ESCR ((NAME VALUE) ...) CLAUSES ...))]
     478
     479                [(sk every TESTNAME CLAUSES ...)
     480                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     481                                                                                [DTOR (datum->syntax-object #'sk 'destructor)]
     482                                                                                [ESCR (datum->syntax-object #'sk 'escape)])
     483                                #'(test:test-case STATE TESTNAME DTOR ESCR CLAUSES ...))]
     484
     485                [(sk TESTNAME ((NAME VALUE) ...) CLAUSES ...)
     486                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     487                                                                                [DTOR (datum->syntax-object #'sk 'destructor)]
     488                                                                                [ESCR (datum->syntax-object #'sk 'escape)])
     489                                #'(test:test-package STATE TESTNAME DTOR ESCR ((NAME VALUE) ...) CLAUSES ...))]
     490
     491                [(sk TESTNAME CLAUSES ...)
     492                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)]
     493                                                                                [DTOR (datum->syntax-object #'sk 'destructor)]
     494                                                                                [ESCR (datum->syntax-object #'sk 'escape)])
     495                                #'(test:test-package STATE TESTNAME DTOR ESCR CLAUSES ...))]
    299496        ))
    300497
     
    305502;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    306503
    307 (define-syntax side-effect
     504(define-syntax test:side-effect
    308505        (syntax-rules ()
    309                 [(_ clauses ...)
    310                         (begin clauses ...
    311                                 (test:make-ignore-result))]
    312         ))
    313 
    314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    315 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    316 
    317 (define-syntax test-continue?
    318         (syntax-rules ()
    319                 [(_ flag)
    320                         (side-effect (test:do-test-case-continue-set! flag))]
    321         ))
    322 
    323 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    325 
    326 (define-syntax test-timing?
    327         (syntax-rules ()
    328                 [(_ flag)
    329                         (side-effect (test:do-timing-set! flag))]
    330         ))
     506                [(_ STATE CLAUSES ...)
     507                        (begin
     508                                CLAUSES ...
     509                                (test:make-ignore-result STATE))]))
     510
     511(define-syntax (side-effect X)
     512        (syntax-case X ()
     513                [(sk CLAUSES ...)
     514                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     515                                #'(test:side-effect STATE CLAUSES ...))]))
     516
     517;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     518;;
     519;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     520
     521(define-syntax (test-continue? X)
     522        (syntax-case X ()
     523                [(sk FLAG)
     524                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     525                                #'(test:side-effect STATE (test:case-continue-set! STATE FLAG)))]))
     526
     527;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     528;;
     529;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     530
     531(define-syntax (test-timing? X)
     532        (syntax-case X ()
     533                [(sk FLAG)
     534                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     535                                #'(test:side-effect STATE (test:timing-set! STATE FLAG)))]))
     536
     537;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     538;; the macro the user uses to terminate
     539;; (terminate ESCNAME MESSAGE)
     540;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     541
     542(define-syntax (terminate X)
     543        (syntax-case X (warn)
     544                [(sk ESCR MSG)
     545                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     546                                #'(ESCR (test:make-user-termination MSG)))]))
    331547
    332548;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    336552;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    337553
    338 (define-syntax todo
    339         (syntax-rules (warn)
    340 
    341                 [(_ message (warn warning))
    342                         (test:make-todo-result message warning)]
    343 
    344                 [(_ message)
    345                         (test:make-todo-result message)]
     554(define-syntax (todo X)
     555        (syntax-case X (warn)
     556
     557                [(sk MSG (warn WARNING))
     558                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     559                                #'(test:make-todo-result STATE MSG WARNING))]
     560
     561                [(sk MSG)
     562                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     563                                #'(test:make-todo-result STATE MSG))]
    346564        ))
    347565
     
    352570;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    353571
    354 (define-syntax gloss
    355         (syntax-rules (warn)
    356 
    357                 [(_ message (warn warning))
    358                         (test:make-gloss-result message warning)]
    359 
    360                 [(_ message)
    361                         (test:make-gloss-result message)]
     572(define-syntax (gloss X)
     573        (syntax-case X (warn)
     574
     575                [(sk MSG (warn WARNING))
     576                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     577                                #'(test:make-gloss-result STATE MSG WARNING))]
     578
     579                [(sk MSG)
     580                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     581                                #'(test:make-gloss-result STATE MSG))]
    362582        ))
    363583
     
    370590;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    371591
    372 (define-syntax skip
    373         (syntax-rules (warn)
    374 
    375                 [(_ message (warn warning) clauses ...)
    376                         (test:make-skip-result message warning)]
    377 
    378                 [(_ message clauses ...)
    379                         (test:make-skip-result message)]
    380         ))
    381 
    382 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    383 ;; Evaluate test expression in a try block
    384 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    385 
    386 (define-syntax test:try-eval
     592(define-syntax (skip X)
     593        (syntax-case X (warn)
     594
     595                [(sk MSG (warn WARNING) CLAUSES ...)
     596                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     597                                #'(test:make-skip-result STATE MSG WARNING))]
     598
     599                [(sk MSG CLAUSES ...)
     600                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     601                                #'(test:make-skip-result STATE MSG))]
     602        ))
     603
     604;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     605;; Template macros for expectations
     606;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     607
     608(define-syntax test:try-eval-expect
    387609        (syntax-rules ()
    388                 [(_ cls)
    389                         (call/cc
     610                [(_ STATE CLS)
     611                        (call-with-current-continuation
    390612                                (lambda (k)
    391613                                        (with-exception-handler
    392                                                 (lambda (cnd)
    393                                                         (test:timer #f)
    394                                                         (k cnd) )
     614                                                (lambda (exn)
     615                                                        (test:timer-stop! STATE)
     616                                                        (k exn))
    395617                                                (lambda ()
    396                                                         (test:timer #t)
    397                                                         (let ([rslt cls])
    398                                                                 (test:timer #f)
    399                                                                 rslt ) )) ))]
    400         ))
    401 
    402 (define-syntax test:try-eval-N
     618                                                        (test:timer-start! STATE)
     619                                                        (let ([clause CLS])
     620                                                                (test:timer-stop! STATE)
     621                                                                clause)))))]))
     622
     623(define-syntax test:try-eval-expect-values
    403624        (syntax-rules ()
    404                 [(_ cls)
    405                         (test:try-eval (receive cls))]
    406         ))
    407 
    408 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    409 ;; Template macros for expectations
    410 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    411 
    412 (define-syntax test:expect-X
     625                [(_ STATE CLS)
     626                        (test:try-eval-expect STATE (receive CLS))]))
     627
     628(define-syntax test:*expect
    413629  (syntax-rules (warn)
    414630
    415                 [(_ (warn warning) kind pred cls)
    416                         (test:expect-X #f (warn warning) kind pred cls)]
    417 
    418     [(_ kind pred cls)
    419                         (test:expect-X #f kind pred cls)]
    420 
    421                 [(_ msg (warn warning) kind pred cls)
    422                         (let ([message msg])
    423                                 (test:perform-if 'expect message
    424                                         (let* ([clause (test:try-eval cls)]
    425                                                                 [result (pred message clause)])
    426                                          (test:make-expect-result result kind message
    427                                                 'cls clause warning))))]
    428 
    429     [(_ msg kind pred cls)
    430                         (let ([message msg])
    431                                 (test:perform-if 'expect message
    432                                         (let* ([clause (test:try-eval cls)]
    433                                                                 [result (pred message clause)])
    434                                          (test:make-expect-result result kind message
    435                                                 'cls clause))))]
    436         ))
    437 
    438 (define-syntax test:expect-equiv-X
     631                [(_ STATE MSG (warn WARNING) KIND PRED CLS)
     632                        (let ([message MSG])
     633                                (test:perform-if STATE 'expect message
     634                                        (let ([clause (test:try-eval-expect STATE CLS)])
     635                                         (test:make-expect-result STATE (PRED message clause) KIND message 'CLS clause WARNING))))]
     636
     637    [(_ STATE MSG KIND PRED CLS)
     638                        (let ([message MSG])
     639                                (test:perform-if STATE 'expect message
     640                                        (let ([clause (test:try-eval-expect STATE CLS)])
     641                                         (test:make-expect-result STATE (PRED message clause) KIND message 'CLS clause))))]
     642        ))
     643
     644(define-syntax test:*expect-equiv
    439645  (syntax-rules (warn)
    440646
    441     [(_ (warn warning) kind pred arg cls)
    442         (test:expect-equiv-X #f (warn warning) kind pred arg cls)]
    443 
    444     [(_ kind pred arg cls)
    445         (test:expect-equiv-X #f kind pred arg cls)]
    446 
    447     [(_ msg (warn warning) kind pred arg cls)
    448                         (let ([message msg])
    449                                 (test:perform-if 'expect message
    450                                         (let ([argument arg])
    451                                                 (let* ([clause (test:try-eval cls)]
    452                                                                         [result (pred message clause argument)])
    453                                                         (test:make-expect-equivalence-result result kind message
    454                                                                 argument 'cls clause warning)))))]
    455 
    456     [(_ msg kind pred arg cls)
    457                         (let ([message msg])
    458                                 (test:perform-if 'expect message
    459                                         (let ([argument arg])
    460                                                 (let* ([clause (test:try-eval cls)]
    461                                                                         [result (pred message clause argument)])
    462                                                         (test:make-expect-equivalence-result result kind message
    463                                                                 argument 'cls clause)))))]
    464         ))
    465 
    466 (define-syntax test:expect-values-equiv-X
     647    [(_ STATE MSG (warn WARNING) KIND PRED ARG CLS)
     648                        (let ([message MSG])
     649                                (test:perform-if STATE 'expect message
     650                                        (let* ([argument ARG]
     651                                                                 [clause (test:try-eval-expect STATE CLS)])
     652                                                (test:make-expect-equivalence-result STATE (PRED message clause argument) KIND message argument 'CLS clause WARNING))))]
     653
     654    [(_ STATE MSG KIND PRED ARG CLS)
     655                        (let ([message MSG])
     656                                (test:perform-if STATE 'expect message
     657                                        (let* ([argument ARG]
     658                                                                 [clause (test:try-eval-expect STATE CLS)])
     659                                                (test:make-expect-equivalence-result STATE (PRED message clause argument) KIND message argument 'CLS clause))))]
     660        ))
     661
     662(define-syntax test:*expect-values-equiv
    467663  (syntax-rules (warn)
    468664
    469     [(_ (warn warning) pred name arg cls)
    470         (test:expect-values-equiv-X #f (warn warning) pred name arg cls)]
    471 
    472     [(_ pred name arg cls)
    473         (test:expect-values-equiv-X #f pred name arg cls)]
    474 
    475     [(_ msg (warn warning) pred name arg cls)
    476                         (let ([message msg])
    477                                 (test:perform-if 'expect message
    478                                         (let ([argument arg])
    479                                                 (let* ([clause (test:try-eval-N cls)]
    480                                                                         [result (pred message clause argument)])
    481                                                         (test:make-expect-equivalence-result result name message
    482                                                                 'arg 'cls clause warning)))))]
    483 
    484     [(_ msg pred name arg cls)
    485                         (let ([message msg])
    486                                 (test:perform-if 'expect message
    487                                         (let ([argument arg])
    488                                                 (let* ([clause (test:try-eval-N cls)]
    489                                                                         [result (pred message clause argument)])
    490                                                         (test:make-expect-equivalence-result result name message
    491                                                                 'arg 'cls clause)))))]
     665    [(_ STATE MSG (warn WARNING) PRED NAME ARG CLS)
     666                        (let ([message MSG])
     667                                (test:perform-if STATE 'expect message
     668                                        (let* ([argument ARG]
     669                                                                 [clause (test:try-eval-expect-values STATE CLS)])
     670                                                (test:make-expect-equivalence-result STATE (PRED message clause argument) NAME message 'ARG 'CLS clause WARNING))))]
     671
     672    [(_ STATE MSG PRED NAME ARG CLS)
     673                        (let ([message MSG])
     674                                (test:perform-if STATE 'expect message
     675                                        (let* ([argument ARG]
     676                                                                 [clause (test:try-eval-expect-values STATE CLS)])
     677                                                (test:make-expect-equivalence-result STATE (PRED message clause argument) NAME message 'ARG 'CLS clause))))]
    492678        ))
    493679
     
    496682;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    497683
    498 (define-syntax expect
     684(define-syntax test:expect
    499685  (syntax-rules (warn)
    500686
    501                 [(_ (warn warning) kind pred cls)
    502                         (expect #f (warn warning) kind pred cls)]
    503 
    504     [(_ kind pred cls)
    505                         (expect #f kind pred cls)]
    506 
    507                 [(_ msg (warn warning) kind pred cls)
    508                         (let ([predicate pred])
    509                                 (test:expect-X msg (warn warning) kind
    510                                         (lambda (m v) (test:_expect-predicate m v predicate)) cls))]
    511 
    512     [(_ msg kind pred cls)
    513                         (let ([predicate pred])
    514                                 (test:expect-X msg kind
    515                                         (lambda (m v) (test:_expect-predicate m v predicate)) cls))]
     687                [(_ STATE MSG (warn WARNING) KIND PRED CLS)
     688                        (let ([predicate PRED])
     689                                (test:*expect STATE MSG (warn WARNING) KIND (lambda (m v) (test:_expect-predicate m v predicate)) CLS))]
     690
     691    [(_ STATE MSG KIND PRED CLS)
     692                        (let ([predicate PRED])
     693                                (test:*expect STATE MSG KIND (lambda (m v) (test:_expect-predicate m v predicate)) CLS))]
     694        ))
     695
     696(define-syntax (expect X)
     697  (syntax-case X (warn)
     698
     699                [(sk (warn WARNING) KIND PRED CLS)
     700                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     701                                #'(test:expect STATE #f (warn WARNING) KIND PRED CLS))]
     702
     703    [(sk KIND PRED CLS)
     704                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     705                                #'(test:expect STATE #f KIND PRED CLS))]
     706
     707                [(sk MSG (warn WARNING) KIND PRED CLS)
     708                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     709                                #'(test:expect STATE MSG (warn WARNING) KIND PRED CLS))]
     710
     711    [(sk MSG KIND PRED CLS)
     712                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     713                                #'(test:expect STATE MSG KIND PRED CLS))]
    516714        ))
    517715
     
    520718;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    521719
    522 (define-syntax expect-zero
     720(define-syntax test:expect-zero
     721        (syntax-rules (warn)
     722
     723                [(_ STATE MSG (warn WARNING) CLS)
     724                        (test:*expect STATE MSG (warn WARNING) "zero" test:_expect-zero CLS)]
     725
     726    [(_ STATE MSG CLS)
     727                        (test:*expect STATE MSG "zero" test:_expect-zero CLS)]
     728        ))
     729
     730(define-syntax (expect-zero X)
     731  (syntax-case X (warn)
     732
     733                [(sk (warn WARNING) CLS)
     734                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     735                                #'(test:expect-zero STATE #f (warn WARNING) CLS))]
     736
     737    [(sk CLS)
     738                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     739                                #'(test:expect-zero STATE #f CLS))]
     740
     741                [(sk MSG (warn WARNING) CLS)
     742                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     743                                #'(test:expect-zero STATE MSG (warn WARNING) CLS))]
     744
     745    [(sk MSG CLS)
     746                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     747                                #'(test:expect-zero STATE MSG CLS))]
     748        ))
     749
     750;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     751;; expect-nonzero: Expect a value to be non-zero
     752;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     753
     754(define-syntax test:expect-nonzero
     755        (syntax-rules (warn)
     756
     757    [(_ STATE MSG (warn WARNING) CLS)
     758                        (test:*expect STATE MSG (warn WARNING) "nonzero" test:_expect-nonzero CLS)]
     759
     760    [(_ STATE MSG CLS)
     761                        (test:*expect STATE MSG "nonzero" test:_expect-nonzero CLS)]
     762        ))
     763
     764(define-syntax (expect-nonzero X)
     765  (syntax-case X (warn)
     766
     767    [(sk (warn WARNING) CLS)
     768                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     769                                #'(test:expect-nonzero STATE #f (warn WARNING) CLS))]
     770
     771    [(sk CLS)
     772                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     773                                #'(test:expect-nonzero STATE #f CLS))]
     774
     775    [(sk MSG (warn WARNING) CLS)
     776                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     777                                #'(test:expect-nonzero STATE MSG (warn WARNING) CLS))]
     778
     779    [(sk MSG CLS)
     780                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     781                                #'(test:expect-nonzero STATE MSG CLS))]
     782        ))
     783
     784;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     785;; expect-true: Expect a value to be #t
     786;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     787
     788(define-syntax test:expect-true
     789        (syntax-rules (warn)
     790
     791    [(_ STATE MSG (warn WARNING) CLS)
     792                        (test:*expect STATE MSG (warn WARNING) "true" test:_expect-true CLS)]
     793
     794    [(_ STATE MSG CLS)
     795                        (test:*expect STATE MSG "true" test:_expect-true CLS)]
     796        ))
     797
     798(define-syntax (expect-true X)
     799  (syntax-case X (warn)
     800
     801    [(sk (warn WARNING) CLS)
     802                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     803                                #'(test:expect-true STATE #f (warn WARNING) CLS))]
     804
     805    [(sk CLS)
     806                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     807                                #'(test:expect-true STATE #f CLS))]
     808
     809    [(sk MSG (warn WARNING) CLS)
     810                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     811                                #'(test:expect-true STATE MSG (warn WARNING) CLS))]
     812
     813    [(sk MSG CLS)
     814                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     815                                #'(test:expect-true STATE MSG CLS))]
     816        ))
     817
     818;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     819;; expect-false: Expect a value to be #f
     820;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     821
     822(define-syntax test:expect-false
     823        (syntax-rules (warn)
     824
     825    [(_ STATE MSG (warn WARNING) CLS)
     826                        (test:*expect STATE MSG (warn WARNING) "false" test:_expect-false CLS)]
     827
     828    [(_ STATE MSG CLS)
     829                        (test:*expect STATE MSG "false" test:_expect-false CLS)]
     830        ))
     831
     832(define-syntax (expect-false X)
     833  (syntax-case X (warn)
     834
     835    [(sk (warn WARNING) CLS)
     836                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     837                                #'(test:expect-false STATE #f (warn WARNING) CLS))]
     838
     839    [(sk CLS)
     840                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     841                                #'(test:expect-false STATE #f CLS))]
     842
     843    [(sk MSG (warn WARNING) CLS)
     844                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     845                                #'(test:expect-false STATE MSG (warn WARNING) CLS))]
     846
     847    [(sk MSG CLS)
     848                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     849                                #'(test:expect-false STATE MSG CLS))]
     850        ))
     851
     852;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     853;; expect-success: Expect a value to be #f or an exception
     854;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     855
     856(define-syntax test:expect-success
    523857  (syntax-rules (warn)
    524858
    525                 [(_ (warn warning) cls)
    526                         (expect-zero #f (warn warning) cls)]
    527 
    528     [(_ cls)
    529                         (expect-zero #f cls)]
    530 
    531                 [(_ msg (warn warning) cls)
    532                         (test:expect-X msg (warn warning) "zero" test:_expect-zero cls)]
    533 
    534     [(_ msg cls)
    535                         (test:expect-X msg "zero" test:_expect-zero cls)]
    536         ))
    537 
    538 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    539 ;; expect-nonzero: Expect a value to be non-zero
    540 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    541 
    542 (define-syntax expect-nonzero
    543   (syntax-rules (warn)
    544 
    545     [(_ (warn warning) cls)
    546                         (expect-nonzero #f (warn warning) cls)]
    547 
    548     [(_ cls)
    549                         (expect-nonzero #f cls)]
    550 
    551     [(_ msg (warn warning) cls)
    552                         (test:expect-X msg (warn warning) "nonzero" test:_expect-nonzero cls)]
    553 
    554     [(_ msg cls)
    555                         (test:expect-X msg "nonzero" test:_expect-nonzero cls)]
    556         ))
    557 
    558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    559 ;; expect-true: Expect a value to be #t
    560 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    561 
    562 (define-syntax expect-true
    563   (syntax-rules (warn)
    564 
    565     [(_ (warn warning) cls)
    566                         (expect-true #f (warn warning) cls)]
    567 
    568     [(_ cls)
    569                         (expect-true #f cls)]
    570 
    571     [(_ msg (warn warning) cls)
    572                         (test:expect-X msg (warn warning) "true" test:_expect-true cls)]
    573 
    574     [(_ msg cls)
    575                         (test:expect-X msg "true" test:_expect-true cls)]
    576         ))
    577 
    578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    579 ;; expect-false: Expect a value to be #f
    580 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    581 
    582 (define-syntax expect-false
    583   (syntax-rules (warn)
    584 
    585     [(_ (warn warning) cls)
    586                         (expect-false #f (warn warning) cls)]
    587 
    588     [(_ cls)
    589                         (expect-false #f cls)]
    590 
    591     [(_ msg (warn warning) cls)
    592                         (test:expect-X msg (warn warning) "false" test:_expect-false cls)]
    593 
    594     [(_ msg cls)
    595                         (test:expect-X msg "false" test:_expect-false cls)]
    596         ))
    597 
    598 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    599 ;; expect-success: Expect a value to be #f or an exception
    600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    601 
    602 (define-syntax expect-success
    603   (syntax-rules (warn)
    604 
    605     [(_ (warn warning) cls)
    606                         (expect-success #f (warn warning) cls)]
    607 
    608     [(_ cls)
    609                         (expect-success #f cls)]
    610 
    611     [(_ msg (warn warning) cls)
    612                         (test:expect-X msg (warn warning) "success" test:_expect-success cls)]
    613 
    614     [(_ msg cls)
    615                         (test:expect-X msg "success" test:_expect-success cls)]
     859    [(_ STATE MSG (warn WARNING) CLS)
     860                        (test:*expect STATE MSG (warn WARNING) "success" test:_expect-success CLS)]
     861
     862    [(_ STATE MSG CLS)
     863                        (test:*expect STATE MSG "success" test:_expect-success CLS)]
     864        ))
     865
     866(define-syntax (expect-success X)
     867  (syntax-case X (warn)
     868
     869    [(sk (warn WARNING) CLS)
     870                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     871                                #'(test:expect-success STATE #f (warn WARNING) CLS))]
     872
     873    [(sk CLS)
     874                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     875                                #'(test:expect-success STATE #f CLS))]
     876
     877    [(sk MSG (warn WARNING) CLS)
     878                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     879                                #'(test:expect-success STATE MSG (warn WARNING) CLS))]
     880
     881    [(sk MSG CLS)
     882                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     883                                #'(test:expect-success STATE MSG CLS))]
    616884        ))
    617885
     
    620888;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    621889
    622 (define-syntax expect-failure
    623   (syntax-rules (warn)
    624 
    625     [(_ (warn warning) cls)
    626                         (expect-failure #f (warn warning) cls)]
    627 
    628     [(_ cls)
    629                         (expect-failure #f cls)]
    630 
    631     [(_ msg (warn warning) cls)
    632                         (test:expect-X msg (warn warning) "failure" test:_expect-failure cls)]
    633 
    634     [(_ msg cls)
    635                         (test:expect-X msg "failure" test:_expect-failure cls)]
     890(define-syntax test:expect-failure
     891        (syntax-rules (warn)
     892
     893    [(_ STATE MSG (warn WARNING) CLS)
     894                        (test:*expect STATE MSG (warn WARNING) "failure" test:_expect-failure CLS)]
     895
     896    [(_ STATE MSG CLS)
     897                        (test:*expect STATE MSG "failure" test:_expect-failure CLS)]
     898        ))
     899
     900(define-syntax (expect-failure X)
     901  (syntax-case X (warn)
     902
     903    [(sk (warn WARNING) CLS)
     904                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     905                                #'(test:expect-failure STATE #f (warn WARNING) CLS))]
     906
     907    [(sk CLS)
     908                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     909                                #'(test:expect-failure STATE #f CLS))]
     910
     911    [(sk MSG (warn WARNING) CLS)
     912                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     913                                #'(test:expect-failure STATE MSG (warn WARNING) CLS))]
     914
     915    [(sk MSG CLS)
     916                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     917                                #'(test:expect-failure STATE MSG CLS))]
    636918        ))
    637919
     
    640922;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    641923
    642 (define-syntax expect-positive
    643   (syntax-rules (warn)
    644 
    645     [(_ (warn warning) cls)
    646                         (expect-positive #f (warn warning) cls)]
    647 
    648     [(_ cls)
    649                         (expect-positive #f cls)]
    650 
    651     [(_ msg (warn warning) cls)
    652                         (test:expect-X msg (warn warning) "positive" test:_expect-positive cls)]
    653 
    654     [(_ msg cls)
    655                         (test:expect-X msg "positive" test:_expect-positive cls)]
     924(define-syntax test:expect-positive
     925        (syntax-rules (warn)
     926
     927    [(_ STATE MSG (warn WARNING) CLS)
     928                        (test:*expect STATE MSG (warn WARNING) "positive" test:_expect-positive CLS)]
     929
     930    [(_ STATE MSG CLS)
     931                        (test:*expect STATE MSG "positive" test:_expect-positive CLS)]
     932        ))
     933
     934(define-syntax (expect-positive X)
     935  (syntax-case X (warn)
     936
     937    [(sk (warn WARNING) CLS)
     938                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     939                                #'(test:expect-positive STATE #f (warn WARNING) CLS))]
     940
     941    [(sk CLS)
     942                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     943                                #'(test:expect-positive STATE #f CLS))]
     944
     945    [(sk MSG (warn WARNING) CLS)
     946                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     947                                #'(test:expect-positive STATE MSG (warn WARNING) CLS))]
     948
     949    [(sk MSG CLS)
     950                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     951                                #'(test:expect-positive STATE MSG CLS))]
    656952        ))
    657953
     
    660956;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    661957
    662 (define-syntax expect-negative
    663   (syntax-rules (warn)
    664 
    665     [(_ (warn warning) cls)
    666                         (expect-negative #f (warn warning) cls)]
    667 
    668     [(_ cls)
    669                         (expect-negative #f cls)]
    670 
    671     [(_ msg (warn warning) cls)
    672                         (test:expect-X msg (warn warning) "negative" test:_expect-negative cls)]
    673 
    674     [(_ msg cls)
    675                         (test:expect-X msg "negative" test:_expect-negative cls)]
     958(define-syntax test:expect-negative
     959        (syntax-rules (warn)
     960
     961    [(_ STATE MSG (warn WARNING) CLS)
     962                        (test:*expect STATE MSG (warn WARNING) "negative" test:_expect-negative CLS)]
     963
     964    [(_ STATE MSG CLS)
     965                        (test:*expect STATE MSG "negative" test:_expect-negative CLS)]
     966        ))
     967
     968(define-syntax (expect-negative X)
     969  (syntax-case X (warn)
     970
     971    [(sk (warn WARNING) CLS)
     972                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     973                                #'(test:expect-negative STATE #f (warn WARNING) CLS))]
     974
     975    [(sk CLS)
     976                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     977                                #'(test:expect-negative STATE #f CLS))]
     978
     979    [(sk MSG (warn WARNING) CLS)
     980                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     981                                #'(test:expect-negative STATE MSG (warn WARNING) CLS))]
     982
     983    [(sk MSG CLS)
     984                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     985                                #'(test:expect-negative STATE MSG CLS))]
    676986        ))
    677987
     
    682992;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    683993
    684 (define-syntax expect-not-false
     994(define-syntax test:expect-not-false
     995        (syntax-rules (warn)
     996
     997    [(_ STATE MSG (warn WARNING) CLS)
     998                        (test:*expect STATE MSG (warn WARNING) "not-false" test:_expect-not-false CLS)]
     999
     1000    [(_ STATE MSG CLS)
     1001                        (test:*expect STATE MSG "not-false" test:_expect-not-false CLS)]
     1002        ))
     1003
     1004(define-syntax (expect-not-false X)
     1005  (syntax-case X (warn)
     1006
     1007    [(sk (warn WARNING) CLS)
     1008                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1009                                #'(test:expect-not-false STATE #f (warn WARNING) CLS))]
     1010
     1011    [(sk CLS)
     1012                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1013                                #'(test:expect-not-false STATE #f CLS))]
     1014
     1015    [(sk MSG (warn WARNING) CLS)
     1016                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1017                                #'(test:expect-not-false STATE MSG (warn WARNING) CLS))]
     1018
     1019    [(sk MSG CLS)
     1020                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1021                                #'(test:expect-not-false STATE MSG CLS))]
     1022        ))
     1023
     1024;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1025;; expect-equiv: Expect a value that will meet the predicate
     1026;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1027
     1028(define-syntax test:expect-equiv
     1029        (syntax-rules (warn)
     1030
     1031                [(_ STATE MSG (warn WARNING) KIND PRED ARG CLS)
     1032                        (let ([predicate PRED])
     1033                                (test:*expect-equiv STATE MSG (warn WARNING) KIND
     1034                                        (lambda (m v a) (test:_expect-equiv-predicate m v a predicate)) ARG CLS))]
     1035
     1036    [(_ STATE MSG KIND PRED ARG CLS)
     1037                        (let ([predicate PRED])
     1038                                (test:*expect-equiv STATE MSG KIND
     1039                                        (lambda (m v a) (test:_expect-equiv-predicate m v a predicate)) ARG CLS))]
     1040        ))
     1041
     1042(define-syntax (expect-equiv X)
     1043  (syntax-case X (warn)
     1044
     1045                [(sk (warn WARNING) KIND PRED ARG CLS)
     1046                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1047                                #'(test:expect-equiv STATE #f (warn WARNING) KIND PRED ARG CLS))]
     1048
     1049    [(sk KIND PRED ARG CLS)
     1050                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1051                                #'(test:expect-equiv STATE #f KIND PRED ARG CLS))]
     1052
     1053                [(sk MSG (warn WARNING) KIND PRED ARG CLS)
     1054                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1055                                #'(test:expect-equiv STATE MSG (warn WARNING) KIND PRED ARG CLS))]
     1056
     1057    [(sk MSG KIND PRED ARG CLS)
     1058                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1059                                #'(test:expect-equiv STATE MSG KIND PRED ARG CLS))]
     1060        ))
     1061
     1062;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1063;; expect-eq: Expect the eq? relation to hold between clause and argument
     1064;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1065
     1066(define-syntax test:expect-eq
     1067        (syntax-rules (warn)
     1068
     1069    [(_ STATE MSG (warn WARNING) ARG CLS)
     1070                        (test:*expect-equiv STATE MSG (warn WARNING) "eq" test:_expect-eq ARG CLS)]
     1071
     1072    [(_ STATE MSG ARG CLS)
     1073                        (test:*expect-equiv STATE MSG "eq" test:_expect-eq ARG CLS)]
     1074        ))
     1075
     1076(define-syntax (expect-eq X)
     1077  (syntax-case X (warn)
     1078
     1079    [(sk (warn WARNING) ARG CLS)
     1080                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1081                                #'(test:expect-eq STATE #f (warn WARNING) ARG CLS))]
     1082
     1083    [(sk ARG CLS)
     1084                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1085                                #'(test:expect-eq STATE #f ARG CLS))]
     1086
     1087    [(sk MSG (warn WARNING) ARG CLS)
     1088                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1089                                #'(test:expect-eq STATE MSG (warn WARNING) ARG CLS))]
     1090
     1091    [(sk MSG ARG CLS)
     1092                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1093                                #'(test:expect-eq STATE MSG ARG CLS))]
     1094        ))
     1095
     1096;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1097;; expect-eqv: Expect the eqv? relation to hold between clause and argument
     1098;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1099
     1100(define-syntax test:expect-eqv
     1101        (syntax-rules (warn)
     1102
     1103    [(_ STATE MSG (warn WARNING) ARG CLS)
     1104                        (test:*expect-equiv STATE MSG (warn WARNING) "eqv" test:_expect-eqv ARG CLS)]
     1105
     1106    [(_ STATE MSG ARG CLS)
     1107                        (test:*expect-equiv STATE MSG "eqv" test:_expect-eqv ARG CLS)]
     1108        ))
     1109
     1110(define-syntax (expect-eqv X)
     1111  (syntax-case X (warn)
     1112
     1113    [(sk (warn WARNING) ARG CLS)
     1114                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1115                                #'(test:expect-eqv STATE #f (warn WARNING) ARG CLS))]
     1116
     1117    [(sk ARG CLS)
     1118                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1119                                #'(test:expect-eqv STATE #f ARG CLS))]
     1120
     1121    [(sk MSG (warn WARNING) ARG CLS)
     1122                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1123                                #'(test:expect-eqv STATE MSG (warn WARNING) ARG CLS))]
     1124
     1125    [(sk MSG ARG CLS)
     1126                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1127                                #'(test:expect-eqv STATE MSG ARG CLS))]
     1128        ))
     1129
     1130;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1131;; expect-equal: Expect the equal? relation to hold between clause and argument
     1132;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1133
     1134(define-syntax test:expect-equal
    6851135  (syntax-rules (warn)
    6861136
    687     [(_ (warn warning) cls)
    688                         (expect-not-false #f (warn warning) cls)]
    689 
    690     [(_ cls)
    691                         (expect-not-false #f cls)]
    692 
    693     [(_ msg (warn warning) cls)
    694                         (test:expect-X msg (warn warning) "not-false" test:_expect-not-false cls)]
    695 
    696     [(_ msg cls)
    697                         (test:expect-X msg "not-false" test:_expect-not-false cls)]
    698         ))
    699 
    700 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    701 ;; expect-equiv: Expect a value that will meet the predicate
    702 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    703 
    704 (define-syntax expect-equiv
    705   (syntax-rules (warn)
    706 
    707                 [(_ (warn warning) kind pred arg cls)
    708                         (expect-equiv #f (warn warning) kind pred arg cls)]
    709 
    710     [(_ kind pred arg cls)
    711                         (expect-equiv #f kind pred arg cls)]
    712 
    713                 [(_ msg (warn warning) kind pred arg cls)
    714                         (let ([predicate pred])
    715                                 (test:expect-equiv-X msg (warn warning) kind
    716                                         (lambda (m v a) (test:_expect-equiv-predicate m v a predicate)) arg cls))]
    717 
    718     [(_ msg kind pred arg cls)
    719                         (let ([predicate pred])
    720                                 (test:expect-equiv-X msg kind
    721                                         (lambda (m v a) (test:_expect-equiv-predicate m v a predicate)) arg cls))]
    722         ))
    723 
    724 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    725 ;; expect-eq: Expect the eq? relation to hold between clause and argument
    726 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    727 
    728 (define-syntax expect-eq
    729   (syntax-rules (warn)
    730 
    731     [(_ (warn warning) arg cls)
    732                         (expect-eq #f (warn warning) arg cls)]
    733 
    734     [(_ arg cls)
    735                         (expect-eq #f arg cls)]
    736 
    737     [(_ msg (warn warning) arg cls)
    738                         (test:expect-equiv-X msg (warn warning) "eq" test:_expect-eq arg cls)]
    739 
    740     [(_ msg arg cls)
    741                         (test:expect-equiv-X msg "eq" test:_expect-eq arg cls)]
    742         ))
    743 
    744 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    745 ;; expect-eqv: Expect the eqv? relation to hold between clause and argument
    746 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    747 
    748 (define-syntax expect-eqv
    749   (syntax-rules (warn)
    750 
    751     [(_ (warn warning) arg cls)
    752                         (expect-eqv #f (warn warning) arg cls)]
    753 
    754     [(_ arg cls)
    755                         (expect-eqv #f arg cls)]
    756 
    757     [(_ msg (warn warning) arg cls)
    758                         (test:expect-equiv-X msg (warn warning) "eqv" test:_expect-eqv arg cls)]
    759 
    760     [(_ msg arg cls)
    761                         (test:expect-equiv-X msg "eqv" test:_expect-eqv arg cls)]
    762         ))
    763 
    764 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    765 ;; expect-equal: Expect the equal? relation to hold between clause and argument
    766 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    767 
    768 (define-syntax expect-equal
    769   (syntax-rules (warn)
    770 
    771     [(_ (warn warning) arg cls)
    772                         (expect-equal #f (warn warning) arg cls)]
    773 
    774     [(_ arg cls)
    775                         (expect-equal #f arg cls)]
    776 
    777     [(_ msg (warn warning) arg cls)
    778                         (test:expect-equiv-X msg (warn warning) "equal" test:_expect-equal arg cls)]
    779 
    780     [(_ msg arg cls)
    781                         (test:expect-equiv-X msg "equal" test:_expect-equal arg cls)]
     1137    [(_ STATE MSG (warn WARNING) ARG CLS)
     1138                        (test:*expect-equiv STATE MSG (warn WARNING) "equal" test:_expect-equal ARG CLS)]
     1139
     1140    [(_ STATE MSG ARG CLS)
     1141                        (test:*expect-equiv STATE MSG "equal" test:_expect-equal ARG CLS)]
     1142        ))
     1143
     1144(define-syntax (expect-equal X)
     1145  (syntax-case X (warn)
     1146
     1147    [(sk (warn WARNING) ARG CLS)
     1148                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1149                                #'(test:expect-equal STATE #f (warn WARNING) ARG CLS))]
     1150
     1151    [(sk ARG CLS)
     1152                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1153                                #'(test:expect-equal STATE #f ARG CLS))]
     1154
     1155    [(sk MSG (warn WARNING) ARG CLS)
     1156                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1157                                #'(test:expect-equal STATE MSG (warn WARNING) ARG CLS))]
     1158
     1159    [(sk MSG ARG CLS)
     1160                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1161                                #'(test:expect-equal STATE MSG ARG CLS))]
    7821162        ))
    7831163
     
    7861166;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    7871167
    788 (define-syntax expect-near
    789   (syntax-rules (warn)
    790 
    791     [(_ (warn warning) arg tol cls)
    792         (expect-near #f (warn warning) arg tol cls)]
    793 
    794     [(_ arg tol cls)
    795         (expect-near #f arg tol cls)]
    796 
    797     [(_ msg (warn warning) arg tol cls)
    798                         (let ([message msg])
    799                                 (test:perform-if 'expect message
    800                                         (let ([argument arg] [tolerance tol])
    801                                                 (let* ([clause (test:try-eval cls)]
    802                                                                         [result (test:_expect-near message clause tolerance argument)])
    803                                                         (test:make-expect-tolerance-result result "near" message
    804                                                                 argument tol 'cls clause warning)))))]
    805 
    806     [(_ msg arg tol cls)
    807                         (let ([message msg])
    808                                 (test:perform-if 'expect message
    809                                         (let ([argument arg] [tolerance tol])
    810                                                 (let* ([clause (test:try-eval cls)]
    811                                                                         [result (test:_expect-near message clause tolerance argument)])
    812                                                         (test:make-expect-tolerance-result result "near" message
    813                                                                 argument tol 'cls clause)))))]
     1168(define-syntax test:expect-near
     1169        (syntax-rules (warn)
     1170
     1171    [(_ STATE MSG (warn WARNING) ARG TOL CLS)
     1172                        (let ([message MSG])
     1173                                (test:perform-if STATE 'expect message
     1174                                        (let ([argument ARG]
     1175                                                                [tolerance TOL]
     1176                                                                [clause (test:try-eval-expect STATE CLS)])
     1177                                                (test:make-expect-tolerance-result STATE (test:_expect-near message clause tolerance argument) "near" message argument tolerance 'CLS clause WARNING))))]
     1178
     1179    [(_ STATE MSG ARG TOL CLS)
     1180                        (let ([message MSG])
     1181                                (test:perform-if STATE 'expect message
     1182                                        (let ([argument ARG]
     1183                                                                [tolerance TOL]
     1184                                                                [clause (test:try-eval-expect STATE CLS)])
     1185                                                (test:make-expect-tolerance-result STATE (test:_expect-near message clause tolerance argument) "near" message argument tolerance 'CLS clause))))]
     1186        ))
     1187
     1188(define-syntax (expect-near X)
     1189  (syntax-case X (warn)
     1190
     1191    [(sk (warn WARNING) ARG TOL CLS)
     1192        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1193                                #'(test:expect-near STATE #f (warn WARNING) ARG TOL CLS))]
     1194
     1195    [(sk ARG TOL CLS)
     1196        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1197                                #'(test:expect-near STATE #f ARG TOL CLS))]
     1198
     1199    [(sk MSG (warn WARNING) ARG TOL CLS)
     1200                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1201                                #'(test:expect-near STATE MSG (warn WARNING) ARG TOL CLS))]
     1202
     1203    [(sk MSG ARG TOL CLS)
     1204                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1205                                #'(test:expect-near STATE MSG ARG TOL CLS))]
    8141206        ))
    8151207
     
    8181210;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    8191211
    820 (define-syntax expect-values
    821   (syntax-rules (warn)
    822 
    823     [(_ (warn warning) arg cls)
    824         (expect-values #f (warn warning) arg cls)]
    825 
    826     [(_ arg cls)
    827         (expect-values #f arg cls)]
    828 
    829     [(_ msg (warn warning) arg cls)
    830                         (let ([message msg])
    831                                 (test:perform-if 'expect message
    832                                         (let ([argument arg])
    833                                                 (let* ([clause (test:try-eval-N cls)]
    834                                                                         [result (test:_expect-values message clause argument)])
    835                                                         (test:make-expect-equivalence-result result "values" message
    836                                                                 'arg 'cls clause warning)))))]
    837 
    838     [(_ msg arg cls)
    839                         (let ([message msg])
    840                                 (test:perform-if 'expect message
    841                                         (let ([argument arg])
    842                                                 (let* ([clause (test:try-eval-N cls)]
    843                                                                         [result (test:_expect-values message clause argument)])
    844                                                         (test:make-expect-equivalence-result result "values" message
    845                                                                 'arg 'cls clause)))))]
     1212(define-syntax test:expect-values
     1213        (syntax-rules (warn)
     1214
     1215    [(_ STATE MSG (warn WARNING) ARG CLS)
     1216                        (let ([message MSG])
     1217                                (test:perform-if STATE 'expect message
     1218                                        (let ([argument ARG]
     1219                                                                [clause (test:try-eval-expect-values STATE CLS)])
     1220                                                (test:make-expect-equivalence-result STATE (test:_expect-values message clause argument) "values" message 'ARG 'CLS clause WARNING))))]
     1221
     1222    [(_ STATE MSG ARG CLS)
     1223                        (let ([message MSG])
     1224                                (test:perform-if STATE 'expect message
     1225                                        (let ([argument ARG]
     1226                                                                [clause (test:try-eval-expect-values STATE CLS)])
     1227                                                (test:make-expect-equivalence-result STATE (test:_expect-values message clause argument) "values" message 'ARG 'CLS clause))))]
     1228        ))
     1229
     1230(define-syntax (expect-values X)
     1231  (syntax-case X (warn)
     1232
     1233    [(sk (warn WARNING) ARG CLS)
     1234        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1235                                #'(test:expect-values STATE #f (warn WARNING) ARG CLS))]
     1236
     1237    [(sk ARG CLS)
     1238        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1239                                #'(test:expect-values STATE #f ARG CLS))]
     1240
     1241    [(sk MSG (warn WARNING) ARG CLS)
     1242                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1243                                #'(test:expect-values STATE MSG (warn WARNING) ARG CLS))]
     1244
     1245    [(sk MSG ARG CLS)
     1246                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1247                                #'(test:expect-values STATE MSG ARG CLS))]
    8461248        ))
    8471249
     
    8501252;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    8511253
    852 (define-syntax expect-values-eq
    853   (syntax-rules (warn)
    854 
    855     [(_ (warn warning) arg cls)
    856         (expect-values-eq #f (warn warning) arg cls)]
    857 
    858     [(_ arg cls)
    859         (expect-values-eq #f arg cls)]
    860 
    861     [(_ msg (warn warning) arg cls)
    862         (test:expect-values-equiv-X msg (warn warning) test:_expect-values-eq
    863                 "values-eq" arg cls)]
    864 
    865     [(_ msg arg cls)
    866         (test:expect-values-equiv-X msg test:_expect-values-eq
    867                 "values-eq" arg cls)]
     1254(define-syntax test:expect-values-eq
     1255        (syntax-rules (warn)
     1256
     1257    [(_ STATE MSG (warn WARNING) ARG CLS)
     1258                        (test:*expect-values-equiv STATE MSG (warn WARNING) test:_expect-values-eq "values-eq" ARG CLS)]
     1259
     1260    [(_ STATE MSG ARG CLS)
     1261                        (test:*expect-values-equiv STATE MSG test:_expect-values-eq "values-eq" ARG CLS)]
     1262        ))
     1263
     1264(define-syntax (expect-values-eq X)
     1265  (syntax-case X (warn)
     1266
     1267    [(sk (warn WARNING) ARG CLS)
     1268        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1269                                #'(test:expect-values-eq STATE #f (warn WARNING) ARG CLS))]
     1270
     1271    [(sk ARG CLS)
     1272        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1273                                #'(test:expect-values-eq STATE #f ARG CLS))]
     1274
     1275    [(sk MSG (warn WARNING) ARG CLS)
     1276                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1277                                #'(test:expect-values-eq STATE MSG (warn WARNING) ARG CLS))]
     1278
     1279    [(sk MSG ARG CLS)
     1280                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1281                                #'(test:expect-values-eq STATE MSG ARG CLS))]
    8681282        ))
    8691283
     
    8721286;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    8731287
    874 (define-syntax expect-values-eqv
    875   (syntax-rules (warn)
    876 
    877     [(_ (warn warning) arg cls)
    878         (expect-values-eqv #f (warn warning) arg cls)]
    879 
    880     [(_ arg cls)
    881         (expect-values-eqv #f arg cls)]
    882 
    883     [(_ msg (warn warning) arg cls)
    884         (test:expect-values-equiv-X msg (warn warning) test:_expect-values-eqv
    885                 "values-eqv" arg cls)]
    886 
    887     [(_ msg arg cls)
    888         (test:expect-values-equiv-X msg test:_expect-values-eqv
    889                 "values-eqv" arg cls)]
     1288(define-syntax test:expect-values-eqv
     1289        (syntax-rules (warn)
     1290
     1291    [(_ STATE MSG (warn WARNING) ARG CLS)
     1292                        (test:*expect-values-equiv STATE MSG (warn WARNING) test:_expect-values-eqv "values-eqv" ARG CLS)]
     1293
     1294    [(_ STATE MSG ARG CLS)
     1295                        (test:*expect-values-equiv STATE MSG test:_expect-values-eqv "values-eqv" ARG CLS)]
     1296        ))
     1297
     1298(define-syntax (expect-values-eqv X)
     1299  (syntax-case X (warn)
     1300
     1301    [(sk (warn WARNING) ARG CLS)
     1302        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1303                                #'(test:expect-values-eqv STATE #f (warn WARNING) ARG CLS))]
     1304
     1305    [(sk ARG CLS)
     1306        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1307                                #'(test:expect-values-eqv STATE #f ARG CLS))]
     1308
     1309    [(sk MSG (warn WARNING) ARG CLS)
     1310                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1311                                #'(test:expect-values-eqv STATE MSG (warn WARNING) ARG CLS))]
     1312
     1313    [(sk MSG ARG CLS)
     1314                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1315                                #'(test:expect-values-eqv STATE MSG ARG CLS))]
    8901316        ))
    8911317
     
    8941320;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    8951321
    896 (define-syntax expect-values-equal
    897   (syntax-rules (warn)
    898 
    899     [(_ (warn warning) arg cls)
    900         (expect-values-equal #f (warn warning) arg cls)]
    901 
    902     [(_ arg cls)
    903         (expect-values-equal #f arg cls)]
    904 
    905     [(_ msg (warn warning) arg cls)
    906         (test:expect-values-equiv-X msg (warn warning) test:_expect-values-equal
    907                 "values-equal" arg cls)]
    908 
    909     [(_ msg arg cls)
    910         (test:expect-values-equiv-X msg test:_expect-values-equal
    911                 "values-equal" arg cls)]
     1322(define-syntax test:expect-values-equal
     1323        (syntax-rules (warn)
     1324
     1325    [(_ STATE MSG (warn WARNING) ARG CLS)
     1326                        (test:*expect-values-equiv STATE MSG (warn WARNING) test:_expect-values-equal "values-equal" ARG CLS)]
     1327
     1328    [(_ STATE MSG ARG CLS)
     1329                        (test:*expect-values-equiv STATE MSG test:_expect-values-equal "values-equal" ARG CLS)]
     1330        ))
     1331
     1332(define-syntax (expect-values-equal X)
     1333  (syntax-case X (warn)
     1334
     1335    [(sk (warn WARNING) ARG CLS)
     1336        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1337                                #'(test:expect-values-equal STATE #f (warn WARNING) ARG CLS))]
     1338
     1339    [(sk ARG CLS)
     1340        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1341                                #'(test:expect-values-equal STATE #f ARG CLS))]
     1342
     1343    [(sk MSG (warn WARNING) ARG CLS)
     1344                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1345                                #'(test:expect-values-equal STATE MSG (warn WARNING) ARG CLS))]
     1346
     1347    [(sk MSG ARG CLS)
     1348                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1349                                #'(test:expect-values-equal STATE MSG ARG CLS))]
    9121350        ))
    9131351
     
    9151353;; expect-exception: Expect an exception.
    9161354;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    917 
    918 (define-syntax test:cond-prop-def
    919         (syntax-rules ()
    920                 [(_)
    921                         test:undefined-value]
    922         ))
    9231355
    9241356(define-syntax test:cond-prop-ref
    9251357        (syntax-rules ()
    9261358                [(_ EXN KIND-KEY PROP-KEY)
    927                         ((condition-property-accessor 'KIND-KEY 'PROP-KEY (test:cond-prop-def)) EXN)]
    928         ))
     1359                        ((condition-property-accessor 'KIND-KEY 'PROP-KEY (void)) EXN)]))
    9291360
    9301361(define-syntax test:cond-prop-test
     
    9581389
    9591390                [(_ EXN KIND-KEY PROP-KEY)
    960                         (not (eq? (test:cond-prop-def) (test:cond-prop-ref EXN KIND-KEY PROP-KEY)))]
     1391                        (not (eq? (void) (test:cond-prop-ref EXN KIND-KEY PROP-KEY)))]
    9611392        ))
    9621393
     
    9941425(define-syntax test:exn-test-try
    9951426        (syntax-rules ()
    996                 [(_ exn-patt cls value)
    997                         (call/cc
     1427                [(_ STATE PATT CLS VAR)
     1428                        (call-with-current-continuation
    9981429                                (lambda (k)
    9991430                                        (with-exception-handler
    1000                                                 (lambda (the-exn)
    1001                                                         (test:timer #f)
    1002                                                         (set! value the-exn)
    1003                                                         (k (test:exn-test the-exn exn-patt)) )
     1431                                                (lambda (exn)
     1432                                                        (test:timer-stop! STATE)
     1433                                                        (set! VAR exn)
     1434                                                        (k (test:exn-test exn PATT)))
    10041435                                                (lambda ()
    1005                                                         (test:timer #t)
    1006                                                         (set! value cls)
    1007                                                         (test:timer #f)
    1008                                                         #f )) ))]
    1009         ))
    1010 
    1011 (define-syntax expect-exception
     1436                                                        (test:timer-start! STATE)
     1437                                                        (set! VAR CLS)
     1438                                                        (test:timer-stop! STATE)
     1439                                                        #f))))]))
     1440
     1441(define-syntax test:expect-exception
    10121442        (syntax-rules (warn)
    10131443
    1014                 [(_ (warn warning) exn-patt cls)
    1015                         (expect-exception #f (warn warning) exn-patt cls)]
    1016 
    1017                 [(_ exn-patt cls)
    1018                         (expect-exception #f exn-patt cls)]
    1019 
    1020                 [(_ msg (warn warning) exn-patt cls)
    1021                         (let ([message msg])
    1022                                 (test:perform-if 'expect message
    1023                                         (let ([value test:undefined-value])
    1024                                                 (letrec ([clause (test:exn-test-try exn-patt cls value)])
    1025                                                         (let ([result (test:_expect-exception message 'exn-patt clause)])
    1026                                                                 (test:make-expect-equivalence-result result "exception" message
    1027                                                                         'exn-patt 'cls value warning))))))]
    1028 
    1029                 [(_ msg exn-patt cls)
    1030                         (let ([message msg])
    1031                                 (test:perform-if 'expect message
    1032                                         (let ([value test:undefined-value])
    1033                                                 (letrec ([clause (test:exn-test-try exn-patt cls value)])
    1034                                                         (let ([result (test:_expect-exception message 'exn-patt clause)])
    1035                                                                 (test:make-expect-equivalence-result result "exception" message
    1036                                                                         'exn-patt 'cls value))))))]
     1444                [(_ STATE MSG (warn WARNING) PATT CLS)
     1445                        (let ([message MSG])
     1446                                (test:perform-if STATE 'expect message
     1447                                        (let ([value (void)])
     1448                                                (letrec ([clause (test:exn-test-try STATE PATT CLS value)])
     1449                                                        (test:make-expect-equivalence-result STATE (test:_expect-exception message 'PATT clause) "exception" message 'PATT 'CLS value WARNING)))))]
     1450
     1451                [(_ STATE MSG PATT CLS)
     1452                        (let ([message MSG])
     1453                                (test:perform-if STATE 'expect message
     1454                                        (let ([value (void)])
     1455                                                (letrec ([clause (test:exn-test-try STATE PATT CLS value)])
     1456                                                        (test:make-expect-equivalence-result STATE (test:_expect-exception message 'PATT clause) "exception" message 'PATT 'CLS value)))))]
     1457        ))
     1458
     1459(define-syntax (expect-exception X)
     1460        (syntax-case X (warn)
     1461
     1462                [(sk (warn WARNING) PATT CLS)
     1463                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1464                                #'(test:expect-exception STATE #f (warn WARNING) PATT CLS))]
     1465
     1466                [(sk PATT CLS)
     1467                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1468                                #'(test:expect-exception STATE #f PATT CLS))]
     1469
     1470                [(sk MSG (warn WARNING) PATT CLS)
     1471                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1472                                #'(test:expect-exception STATE MSG (warn WARNING) PATT CLS))]
     1473
     1474                [(sk MSG PATT CLS)
     1475                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1476                                #'(test:expect-exception STATE MSG PATT CLS))]
    10371477        ))
    10381478
     
    10411481;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    10421482
    1043 (define-syntax expect-ec
    1044         (syntax-rules (warn => :)
    1045 
    1046                 [(_ (warn WARNING) (QUAL ...) ... ARG => PRED CLS)
    1047                         (expect-ec #f (warn WARNING) (QUAL ...) ... ARG => PRED CLS)]
    1048 
    1049                 [(_ (warn WARNING) (QUAL ...) ... ARG => CLS)
    1050                         (expect-ec (warn WARNING) (QUAL ...) ... ARG CLS)]
    1051 
    1052                 [(_ (warn WARNING) (QUAL ...) ... ARG CLS)
    1053                         (expect-ec (warn WARNING) (QUAL ...) ... ARG => equal? CLS)]
    1054 
    1055                 [(_ (QUAL ...) ... ARG => PRED CLS)
    1056                         (expect-ec #f (QUAL ...) ... ARG => PRED CLS)]
    1057 
    1058                 [(_ (QUAL ...) ... ARG => CLS)
    1059                         (expect-ec (QUAL ...) ... ARG CLS)]
    1060 
    1061                 [(_ (QUAL ...) ... ARG CLS)
    1062                         (expect-ec (QUAL ...) ... ARG => equal? CLS)]
    1063 
    1064                 [(_ MSG (warn WARNING) (QUAL ...) ... ARG => PRED CLS)
     1483(define-syntax test:expect-ec
     1484        (syntax-rules (warn :)
     1485
     1486                [(_ STATE MSG (warn WARNING) (QUAL ...) ... ARG PRED CLS)
    10651487                        (let ([message MSG])
    1066                                 (test:perform-if 'expect message
    1067                                         (let* ([clause
    1068                                                                         (test:try-eval (every?-ec (QUAL ...) ... (PRED ARG CLS)))]
    1069                                                                 [result (test:_expect-true message clause)])
    1070                                                 (test:make-expect-result result "ec" message
    1071                                                         (list 'PRED 'ARG 'CLS) clause WARNING))))]
    1072 
    1073                 [(_ MSG (warn WARNING) (QUAL ...) ... ARG => CLS)
    1074                         (expect-ec MSG (warn WARNING) (QUAL ...) ... ARG CLS)]
    1075 
    1076                 [(_ MSG (warn WARNING) (QUAL ...) ... ARG CLS)
    1077                         (expect-ec MSG (warn WARNING) (QUAL ...) ... ARG => equal? CLS)]
    1078 
    1079                 [(_ MSG (QUAL ...) ... ARG => PRED CLS)
     1488                                (test:perform-if STATE 'expect message
     1489                                        (let ([clause (test:try-eval-expect STATE (every?-ec (QUAL ...) ... (PRED ARG CLS)))])
     1490                                                (test:make-expect-result STATE (test:_expect-true message clause) "ec" message (list 'PRED 'ARG 'CLS) clause WARNING))))]
     1491
     1492                [(_ STATE MSG (QUAL ...) ... ARG PRED CLS)
    10801493                        (let ([message MSG])
    1081                                 (test:perform-if 'expect message
    1082                                         (let* ([clause
    1083                                                                         (test:try-eval (every?-ec (QUAL ...) ... (PRED ARG CLS)))]
    1084                                                                 [result (test:_expect-true message clause)])
    1085                                                 (test:make-expect-result result "ec" message
    1086                                                         (list 'PRED 'ARG 'CLS) clause))))]
    1087 
    1088                 [(_ MSG (QUAL ...) ... ARG => CLS)
    1089                         (expect-ec MSG (QUAL ...) ... ARG CLS)]
    1090 
    1091                 [(_ MSG (QUAL ...) ... ARG CLS)
    1092                         (expect-ec MSG (QUAL ...) ... ARG => equal? CLS)]
    1093         ))
    1094 
    1095 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1096 ;; Some useful additions
    1097 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1098 
    1099 (define-syntax expect-set!
    1100         (syntax-rules ()
    1101                 [(_ SYM EXPR)
    1102                         (let ([result (expect-success (conc "set! " 'SYM) EXPR)])
    1103                                 (when (*-result-ref result)
    1104                                         (side-effect (set! SYM (expect-result-evaled-ref result))))
    1105                                 result)]
    1106         ))
    1107 
    1108 ;; Well, maybe not so useful
    1109 
    1110 (define-syntax expect-successful-failure
    1111         (syntax-rules ()
    1112                 [(_ EXPR)
    1113                         (expect-success "Failure" EXPR)]
    1114         ))
    1115 
    1116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1117 ;; Some Testeez-like wrappers
    1118 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1119 
    1120 ;; Issues
    1121 ;;
    1122 ;; - test/ec doesn't (and can't) follow the usual testeez argument order pattern.
    1123 ;;
    1124 ;; - test-define would require a non-trivial change to the test-group/case/package
    1125 ;; machinery.
    1126 ;;
    1127 ;; Best to provide a '(testeez ...)' form that generates test-infrastructure source.
    1128 
    1129 (define-syntax test/zero
    1130         (syntax-rules ()
    1131                 [(_ EXPR)
    1132                         (expect-zero EXPR)]
    1133                 [(_ DESC EXPR)
    1134                         (expect-zero DESC EXPR)]))
    1135 
    1136 (define-syntax test/nonzero
    1137         (syntax-rules ()
    1138                 [(_ EXPR)
    1139                         (expect-nonzero EXPR)]
    1140                 [(_ DESC EXPR)
    1141                         (expect-nonzero DESC EXPR)]))
    1142 
    1143 (define-syntax test/true
    1144         (syntax-rules ()
    1145                 [(_ EXPR)
    1146                         (expect-true EXPR)]
    1147                 [(_ DESC EXPR)
    1148                         (expect-true DESC EXPR)]))
    1149 
    1150 (define-syntax test/false
    1151         (syntax-rules ()
    1152                 [(_ EXPR)
    1153                         (expect-false EXPR)]
    1154                 [(_ DESC EXPR)
    1155                         (expect-false DESC EXPR)]))
    1156 
    1157 (define-syntax test/success
    1158         (syntax-rules ()
    1159                 [(_ EXPR)
    1160                         (expect-success EXPR)]
    1161                 [(_ DESC EXPR)
    1162                         (expect-success DESC EXPR)]))
    1163 
    1164 (define-syntax test/failure
    1165         (syntax-rules ()
    1166                 [(_ EXPR)
    1167                         (expect-failure EXPR)]
    1168                 [(_ DESC EXPR)
    1169                         (expect-failure DESC EXPR)]))
    1170 
    1171 (define-syntax test/positive
    1172         (syntax-rules ()
    1173                 [(_ EXPR)
    1174                         (expect-positive EXPR)]
    1175                 [(_ DESC EXPR)
    1176                         (expect-positive DESC EXPR)]))
    1177 
    1178 (define-syntax test/negative
    1179         (syntax-rules ()
    1180                 [(_ EXPR)
    1181                         (expect-negative EXPR)]
    1182                 [(_ DESC EXPR)
    1183                         (expect-negative DESC EXPR)]))
    1184 
    1185 (define-syntax test/not-false
    1186         (syntax-rules ()
    1187                 [(_ EXPR)
    1188                         (expect-not-false EXPR)]
    1189                 [(_ DESC EXPR)
    1190                         (expect-not-false DESC EXPR)]))
    1191 
    1192 (define-syntax test/equiv
    1193         (syntax-rules ()
    1194                 [(_ EXPR EXPECTED PRED)
    1195                         (expect-equiv "" PRED EXPECTED EXPR)]
    1196                 [(_ DESC EXPR EXPECTED PRED)
    1197                         (expect-equiv DESC "" PRED EXPECTED EXPR)]))
    1198 
    1199 (define-syntax test/eq
    1200         (syntax-rules ()
    1201                 [(_ EXPR EXPECTED)
    1202                         (expect-eq EXPECTED EXPR)]
    1203                 [(_ DESC EXPR EXPECTED)
    1204                         (expect-eq DESC EXPECTED EXPR)]))
    1205 
    1206 (define-syntax test/eqv
    1207         (syntax-rules ()
    1208                 [(_ EXPR EXPECTED)
    1209                         (expect-eqv EXPECTED EXPR)]
    1210                 [(_ DESC EXPR EXPECTED)
    1211                         (expect-eqv DESC EXPECTED EXPR)]))
    1212 
    1213 (define-syntax test/equal
    1214         (syntax-rules ()
    1215                 [(_ EXPR EXPECTED)
    1216                         (expect-equal EXPECTED EXPR)]
    1217                 [(_ DESC EXPR EXPECTED)
    1218                         (expect-equal DESC EXPECTED EXPR)]))
    1219 
    1220 (define-syntax test/near
    1221         (syntax-rules ()
    1222                 [(_ EXPR EXPECTED)
    1223                         (expect-near EXPECTED 0.0001 EXPR)]
    1224                 [(_ DESC EXPR EXPECTED)
    1225                         (expect-near DESC EXPECTED 0.0001 EXPR)]
    1226                 [(_ DESC EXPR EXPECTED TOL)
    1227                         (expect-near DESC EXPECTED TOL EXPR)]))
    1228 
    1229 (define-syntax test/values
    1230         (syntax-rules ()
    1231                 [(_ EXPR EXPECTED)
    1232                         (expect-values EXPECTED EXPR)]
    1233                 [(_ DESC EXPR EXPECTED)
    1234                         (expect-values DESC EXPECTED EXPR)]))
    1235 
    1236 (define-syntax test/values-eq
    1237         (syntax-rules ()
    1238                 [(_ EXPR EXPECTED)
    1239                         (expect-values-eq EXPECTED EXPR)]
    1240                 [(_ DESC EXPR EXPECTED)
    1241                         (expect-values-eq DESC EXPECTED EXPR)]))
    1242 
    1243 (define-syntax test/values-eqv
    1244         (syntax-rules ()
    1245                 [(_ EXPR EXPECTED)
    1246                         (expect-values-eqv EXPECTED EXPR)]
    1247                 [(_ DESC EXPR EXPECTED)
    1248                         (expect-values-eqv DESC EXPECTED EXPR)]))
    1249 
    1250 (define-syntax test/values-equal
    1251         (syntax-rules ()
    1252                 [(_ EXPR EXPECTED)
    1253                         (expect-values-equal EXPECTED EXPR)]
    1254                 [(_ DESC EXPR EXPECTED)
    1255                         (expect-values-equal DESC EXPECTED EXPR)]))
    1256 
    1257 (define-syntax test/exception
    1258         (syntax-rules ()
    1259                 [(_ EXPR EXPECTED)
    1260                         (expect-exception EXPECTED EXPR)]
    1261                 [(_ DESC EXPR EXPECTED)
    1262                         (expect-exception DESC EXPECTED EXPR)]))
    1263 
    1264 (define-syntax test/ec
    1265         (syntax-rules ()
    1266                 [(_ REST ...)
    1267                         (expect-ec REST ...)]))
     1494                                (test:perform-if STATE 'expect message
     1495                                        (let ([clause (test:try-eval-expect STATE (every?-ec (QUAL ...) ... (PRED ARG CLS)))])
     1496                                                (test:make-expect-result STATE (test:_expect-true message clause) "ec" message (list 'PRED 'ARG 'CLS) clause))))]
     1497        ))
     1498
     1499(define-syntax (expect-ec X)
     1500        (syntax-case X (warn => :)
     1501
     1502                [(sk (warn WARNING) (QUAL ...) ... ARG => PRED CLS)
     1503                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1504                                #'(test:expect-ec STATE #f (warn WARNING) (QUAL ...) ... ARG PRED CLS))]
     1505
     1506                [(sk (warn WARNING) (QUAL ...) ... ARG => CLS)
     1507                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1508                                #'(test:expect-ec STATE #f (warn WARNING) (QUAL ...) ... ARG equal? CLS))]
     1509
     1510                [(sk (warn WARNING) (QUAL ...) ... ARG CLS)
     1511                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1512                                #'(test:expect-ec STATE #f (warn WARNING) (QUAL ...) ... ARG equal? CLS))]
     1513
     1514                [(sk (QUAL ...) ... ARG => PRED CLS)
     1515                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1516                                #'(test:expect-ec STATE #f (QUAL ...) ... ARG PRED CLS))]
     1517
     1518                [(sk (QUAL ...) ... ARG => CLS)
     1519                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1520                                #'(test:expect-ec STATE #f (QUAL ...) ... ARG equal? CLS))]
     1521
     1522                [(sk (QUAL ...) ... ARG CLS)
     1523                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1524                                #'(test:expect-ec STATE #f (QUAL ...) ... ARG equal? CLS))]
     1525
     1526                [(sk MSG (warn WARNING) (QUAL ...) ... ARG => PRED CLS)
     1527                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1528                                #'(test:expect-ec STATE MSG (warn WARNING) (QUAL ...) ... ARG PRED CLS))]
     1529
     1530                [(sk MSG (warn WARNING) (QUAL ...) ... ARG => CLS)
     1531                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1532                                #'(test:expect-ec STATE MSG (warn WARNING) (QUAL ...) ... ARG equal? CLS))]
     1533
     1534                [(sk MSG (warn WARNING) (QUAL ...) ... ARG CLS)
     1535                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1536                                #'(test:expect-ec STATE MSG (warn WARNING) (QUAL ...) ... ARG equal? CLS))]
     1537
     1538                [(sk MSG (QUAL ...) ... ARG => PRED CLS)
     1539                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1540                                #'(test:expect-ec STATE MSG (QUAL ...) ... ARG PRED CLS))]
     1541
     1542                [(sk MSG (QUAL ...) ... ARG => CLS)
     1543                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1544                                #'(test:expect-ec STATE MSG (QUAL ...) ... ARG equal? CLS))]
     1545
     1546                [(sk MSG (QUAL ...) ... ARG CLS)
     1547                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1548                                #'(test:expect-ec STATE MSG (QUAL ...) ... ARG equal? CLS))]
     1549        ))
     1550
     1551;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1552;; expect-set!
     1553;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1554
     1555(define-syntax (expect-set! X)
     1556        (syntax-case X ()
     1557                [(sk VAR EXPR)
     1558                        (identifier? #'VAR)
     1559                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1560                                #'(if (test:eval-mode? STATE)
     1561                                                (let ([result (test:expect-success STATE (conc "set! " 'VAR) EXPR)])
     1562                                                        (when (*-result-ref result)
     1563                                                                (set! VAR (expect-result-evaled-ref result)))
     1564                                                        result)
     1565                                                (void)))]))
     1566
     1567;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1568;; Testeez-like test-define
     1569;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1570
     1571(define-syntax (test-define X)
     1572  (syntax-case X ()
     1573
     1574        [(sk VAR EXPR CLAUSES ...)
     1575                        (identifier? #'VAR)
     1576                (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1577                                #'(let ()
     1578                                        (define VAR (if (test:eval-mode? STATE) EXPR (void)))
     1579                                        CLAUSES ...))]
     1580
     1581        [(sk DESC VAR EXPR CLAUSES ...)
     1582                        (identifier? #'VAR)
     1583                (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1584                                #'(let ()
     1585                                        (define VAR (if (test:eval-mode? STATE) EXPR (void)))
     1586                                        CLAUSES ...))]
     1587        ))
     1588
     1589;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1590;; Testeez-like wrappers
     1591;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1592
     1593(define-syntax (test/zero X)
     1594        (syntax-case X ()
     1595                [(sk EXPR)
     1596                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1597                                #'(test:expect-zero STATE EXPR))]
     1598                [(sk DESC EXPR)
     1599                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1600                                #'(test:expect-zero STATE DESC EXPR))]))
     1601
     1602(define-syntax (test/nonzero X)
     1603        (syntax-case X ()
     1604                [(sk EXPR)
     1605                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1606                                #'(test:expect-nonzero STATE EXPR))]
     1607                [(sk DESC EXPR)
     1608                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1609                                #'(test:expect-nonzero STATE DESC EXPR))]))
     1610
     1611(define-syntax (test/true X)
     1612        (syntax-case X ()
     1613                [(sk EXPR)
     1614                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1615                                #'(test:expect-true STATE EXPR))]
     1616                [(sk DESC EXPR)
     1617                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1618                                #'(test:expect-true STATE DESC EXPR))]))
     1619
     1620(define-syntax (test/false X)
     1621        (syntax-case X ()
     1622                [(sk EXPR)
     1623                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1624                                #'(test:expect-false STATE EXPR))]
     1625                [(sk DESC EXPR)
     1626                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1627                                #'(test:expect-false STATE DESC EXPR))]))
     1628
     1629(define-syntax (test/success X)
     1630        (syntax-case X ()
     1631                [(sk EXPR)
     1632                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1633                                #'(test:expect-success STATE #f EXPR))]
     1634                [(sk DESC EXPR)
     1635                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1636                                #'(test:expect-success STATE DESC EXPR))]))
     1637
     1638(define-syntax (test/failure X)
     1639        (syntax-case X ()
     1640                [(sk EXPR)
     1641                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1642                                #'(test:expect-failure STATE EXPR))]
     1643                [(sk DESC EXPR)
     1644                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1645                                #'(test:expect-failure STATE DESC EXPR))]))
     1646
     1647(define-syntax (test/positive X)
     1648        (syntax-case X ()
     1649                [(sk EXPR)
     1650                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1651                                #'(test:expect-positive STATE EXPR))]
     1652                [(sk DESC EXPR)
     1653                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1654                                #'(test:expect-positive STATE DESC EXPR))]))
     1655
     1656(define-syntax (test/negative X)
     1657        (syntax-case X ()
     1658                [(sk EXPR)
     1659                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1660                                #'(test:expect-negative STATE EXPR))]
     1661                [(sk DESC EXPR)
     1662                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1663                                #'(test:expect-negative STATE DESC EXPR))]))
     1664
     1665(define-syntax (test/not-false X)
     1666        (syntax-case X ()
     1667                [(sk EXPR)
     1668                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1669                                #'(test:expect-not-false STATE EXPR))]
     1670                [(sk DESC EXPR)
     1671                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1672                                #'(test:expect-not-false STATE DESC EXPR))]))
     1673
     1674(define-syntax (test/equiv X)
     1675        (syntax-case X ()
     1676                [(sk EXPR EXPECTED PRED)
     1677                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1678                                #'(test:expect-equiv STATE "" PRED EXPECTED EXPR))]
     1679                [(sk DESC EXPR EXPECTED PRED)
     1680                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1681                                #'(test:expect-equiv STATE DESC "" PRED EXPECTED EXPR))]))
     1682
     1683(define-syntax (test/eq X)
     1684        (syntax-case X ()
     1685                [(sk EXPR EXPECTED)
     1686                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1687                                #'(test:expect-eq STATE EXPECTED EXPR))]
     1688                [(sk DESC EXPR EXPECTED)
     1689                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1690                                #'(test:expect-eq STATE DESC EXPECTED EXPR))]))
     1691
     1692(define-syntax (test/eqv X)
     1693        (syntax-case X ()
     1694                [(sk EXPR EXPECTED)
     1695                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1696                                #'(test:expect-eqv STATE EXPECTED EXPR))]
     1697                [(sk DESC EXPR EXPECTED)
     1698                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1699                                #'(test:expect-eqv STATE DESC EXPECTED EXPR))]))
     1700
     1701(define-syntax (test/equal X)
     1702        (syntax-case X ()
     1703                [(sk EXPR EXPECTED)
     1704                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1705                                #'(test:expect-equal STATE #f EXPECTED EXPR))]
     1706                [(sk DESC EXPR EXPECTED)
     1707                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1708                                #'(test:expect-equal STATE DESC EXPECTED EXPR))]))
     1709
     1710(define-syntax (test/near X)
     1711        (syntax-case X ()
     1712                [(sk EXPR EXPECTED)
     1713                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1714                                #'(test:expect-near STATE EXPECTED 0.0001 EXPR))]
     1715                [(sk DESC EXPR EXPECTED)
     1716                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1717                                #'(test:expect-near STATE DESC EXPECTED 0.0001 EXPR))]
     1718                [(sk DESC EXPR EXPECTED TOL)
     1719                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1720                                #'(test:expect-near STATE DESC EXPECTED TOL EXPR))]))
     1721
     1722(define-syntax (test/values X)
     1723        (syntax-case X ()
     1724                [(sk EXPR EXPECTED)
     1725                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1726                                #'(test:expect-values STATE EXPECTED EXPR))]
     1727                [(sk DESC EXPR EXPECTED)
     1728                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1729                                #'(test:expect-values STATE DESC EXPECTED EXPR))]))
     1730
     1731(define-syntax (test/values-eq X)
     1732        (syntax-case X ()
     1733                [(sk EXPR EXPECTED)
     1734                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1735                                #'(test:expect-values-eq STATE EXPECTED EXPR))]
     1736                [(sk DESC EXPR EXPECTED)
     1737                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1738                                #'(test:expect-values-eq STATE DESC EXPECTED EXPR))]))
     1739
     1740(define-syntax (test/values-eqv X)
     1741        (syntax-case X ()
     1742                [(sk EXPR EXPECTED)
     1743                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1744                                #'(test:expect-values-eqv STATE EXPECTED EXPR))]
     1745                [(sk DESC EXPR EXPECTED)
     1746                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1747                                #'(test:expect-values-eqv STATE DESC EXPECTED EXPR))]))
     1748
     1749(define-syntax (test/values-equal X)
     1750        (syntax-case X ()
     1751                [(sk EXPR EXPECTED)
     1752                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1753                                #'(test:expect-values-equal STATE EXPECTED EXPR))]
     1754                [(sk DESC EXPR EXPECTED)
     1755                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1756                                #'(test:expect-values-equal STATE DESC EXPECTED EXPR))]))
     1757
     1758(define-syntax (test/exception X)
     1759        (syntax-case X ()
     1760                [(sk EXPR EXPECTED)
     1761                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1762                                #'(test:expect-exception STATE EXPECTED EXPR))]
     1763                [(sk DESC EXPR EXPECTED)
     1764                        (with-syntax ([STATE (datum->syntax-object #'sk 'test:state)])
     1765                                #'(test:expect-exception STATE DESC EXPECTED EXPR))]))
  • test-infrastructure/test-infrastructure.setup

    r1756 r2551  
    22
    33(compile-dynld "test-infrastructure-fp" -O3 -d0)
    4 (compile-dynld "test-infrastructure-timing" -O3 -d0)
     4(compile-dynld "test-infrastructure-state" -O3 -d0)
    55(compile-dynld "test-infrastructure-runtime")
    66(compile-dynld "test-infrastructure-support" -O3 -d0)
     
    1414                ,(make-dynld-filename "test-infrastructure-runtime")
    1515                ,(make-dynld-filename "test-infrastructure-fp")
    16                 ,(make-dynld-filename "test-infrastructure-timing")
     16                ,(make-dynld-filename "test-infrastructure-state")
    1717                ,(make-dynld-filename "test-infrastructure-stat")
    1818                ,(make-dynld-filename "test-infrastructure-output")
     
    2020                ,(make-exports-filename "test-infrastructure-runtime")
    2121                ,(make-exports-filename "test-infrastructure-fp")
    22                 ,(make-exports-filename "test-infrastructure-timing")
     22                ,(make-exports-filename "test-infrastructure-state")
    2323                ,(make-exports-filename "test-infrastructure-stat")
    2424                ,(make-exports-filename "test-infrastructure-output")
     
    2626        )
    2727 `(
    28                 (version "1.92")
     28                (version "2.0")
    2929                (documentation "test-infrastructure.html")
    3030                (syntax)
     
    3333                        test-infrastructure-support
    3434                        test-infrastructure-fp
    35                         test-infrastructure-timing
     35                        test-infrastructure-state
    3636                        test-infrastructure-stat
    3737                        test-infrastructure-output)
     
    4040                        ,(make-exports-filename "test-infrastructure-runtime")
    4141                        ,(make-exports-filename "test-infrastructure-fp")
    42                         ,(make-exports-filename "test-infrastructure-timing")
     42                        ,(make-exports-filename "test-infrastructure-state")
    4343                        ,(make-exports-filename "test-infrastructure-stat")
    4444                        ,(make-exports-filename "test-infrastructure-output") )
Note: See TracChangeset for help on using the changeset viewer.