76 lines
3.0 KiB
Scheme
76 lines
3.0 KiB
Scheme
#|
|
|
This module provides a test-case macro for the test-case-box to expand into.
|
|
The test-case box does not immediatly expand into the body of the macro itself
|
|
because the macro is able to check the (syntax-local-context) of the invocation
|
|
to give better error messages when the test-case is not at the top level.
|
|
|#
|
|
|
|
(module test-case mzscheme
|
|
|
|
(provide test-case test-error-case)
|
|
|
|
;; STATUS : Abstract these two syntaxes and use string constant for the error
|
|
(define-syntax (test-case stx)
|
|
(syntax-case stx ()
|
|
[(_ test to-test-stx exp-stx record set-actuals)
|
|
(case (syntax-local-context)
|
|
[(module top-level)
|
|
(syntax-property
|
|
#`(define-values ()
|
|
(let ([to-test-values (call-with-values
|
|
(lambda () #,(syntax-property #`to-test-stx
|
|
'stepper-test-suite-hint
|
|
#t))
|
|
list)]
|
|
[exp-values (call-with-values (lambda () exp-stx) list)])
|
|
(record (and (= (length to-test-values) (length exp-values))
|
|
(andmap test to-test-values exp-values)))
|
|
(set-actuals to-test-values)
|
|
(values)))
|
|
'stepper-skipto
|
|
(list ;define-values
|
|
syntax-e cdr cdr car
|
|
; let-values
|
|
syntax-e cdr car
|
|
; clauses
|
|
syntax-e car syntax-e cdr car
|
|
; call-with-values
|
|
syntax-e cdr syntax-e cdr car
|
|
; lambda
|
|
syntax-e cdr cdr car
|
|
))]
|
|
[else (raise-syntax-error #f
|
|
"test case not at toplevel"
|
|
(syntax/loc stx (test-case to-test-stx exp-stx)))])]))
|
|
|
|
(define-syntax (test-error-case stx)
|
|
(syntax-case stx ()
|
|
[(_ to-test-stx exn-pred exn-handler record set-actuals)
|
|
(case (syntax-local-context)
|
|
[(module top-level)
|
|
(syntax-property
|
|
#'(define-values ()
|
|
(with-handlers ([exn-pred
|
|
(lambda (v)
|
|
(set-actuals (list v))
|
|
(record (exn-handler v))
|
|
(values))]
|
|
[void
|
|
(lambda (v)
|
|
(set-actuals v)
|
|
(record #f)
|
|
(values))])
|
|
to-test-stx
|
|
(record #f)
|
|
(values)))
|
|
'stepper-skipto
|
|
(list ;; define-values
|
|
syntax-e cdr cdr car
|
|
;; with-handlers
|
|
syntax-e cdr cdr cdr car
|
|
))]
|
|
[else (raise-syntax-error #f
|
|
"test case not at toplevel"
|
|
(syntax/loc stx (test-case to-test-stx exp-stx)))])]))
|
|
)
|