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

;;;; test-infrastructure-hygienic.scm - Test-macros and support code
;;;; Copyright (c) Peter K. Keller 2002
;;;; Written by Peter K. Keller (psilord@cs.wisc.edu) for use with the CHICKEN
;;;; scheme compiler and whoever else wants to use it. Just please include this
;;;; little paragraph in any source code derived from the original. This
;;;; source code is free to use for any purpose, but no warranty or guarantee
;;;; to its stability or robustness is implied in any way. You may not hold me
;;;; or anyone else liable for any use of this source code. Please try to keep
;;;; this source code as close to R5RS(or later) scheme as possible. Thank you.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; perform a left to right evaluation of a list of expectations stopping at
;; the first false one, and returning a list of all of the results from the
;; evaluated expectations.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax test:eval-expectations
(syntax-rules ()
        ((_ exp)
                (list exp))

        ((_ exp-head exp-tail ...)
                (let ((head exp-head)) ;; evaluate exp-head right here!
                        (cond
                        ((or
                                ;; XXX There might be a better way to do this check for
                                ;; truth. I don't like this use of type checking functions
                                ;; here... It causes you to modify this when you add a new
                                ;; expectation type.
                                (and    (expect-result? head)
                                                (equal? #t
                                                        (expect-result-result-ref head)))
                                (and    (expect-equivalence-result? head)
                                                (equal? #t
                                                        (expect-equivalence-result-result-ref head)))
                                (and    (expect-tolerance-result? head)
                                                (equal? #t
                                                        (expect-tolerance-result-result-ref head)))

                                ;; assume ignored results are true for this macro so you
                                ;; can keep evaluating.
                                (ignore-result? head)

                                ;; assume skipped results are true for this macro so you
                                ;; can keep evaluating.
                                (skip-result? head)

                                ;; assume todo results are true for this macro so you
                                ;; can keep evaluating.
                                (todo-result? head)

                                ;; assume gloss results are true for this macro so you
                                ;; can keep evaluating.
                                (gloss-result? head))

                                ;; only continue evaluating down the list if the expectation
                                ;; turned out to be true
                                (cons head (test:eval-expectations exp-tail ...)))

                        (else ;; save the first false one in the master list
                                (list head)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; perform a left to right evaluation of a list of exps returning a list of
;; all of the results from the evaluated expectations.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax test:eval-lr
        (syntax-rules ()
                ((_ exp)
                        (list exp))

                ((_ exp-head exp-tail ...)
                        (let ((head exp-head)) ;; evaluate exp-head right here!
                                (cons head (test:eval-lr exp-tail ...))))))

;; this is the definition of the macro test-case:
;; (test-case DESC DEST-NAME TERM-NAME EXPECTATIONS)
;; (test-case DESC DEST-NAME TERM-NAME (warn WARNING) EXPECTATIONS)
;; (test-case DESC DEST-NAME TERM-NAME (FORMALS) EXPECTATIONS)
;; (test-case DESC DEST-NAME TERM-NAME (warn WARNING) (FORMALS) EXPECTATIONS)
;; DESC is an object (usually a string) that explains what the test-case is.
;; DEST-NAME is the name of the destructor object provided for you in the
;;      scope of the test-case(allows you to clean things up in case of
;;      termination). The destructor object automatically when the expectations
;;      have finished for any reason.
;; TERM-NAME is the name of the escape function you must pass to (terminate ...)
;;      when you want to abort the test case.
;; EXPECTATIONS are a list of expect-* macros and destructor manipulation
;;      calls. The first expectation that fails stops the evaluation in the test
;;      case.
;; WARNING is a string(actually any type, but usually string) message that
;;      expains that something isn't quite right or there are special circumstances
;;      to something.
;; FORMALS are let-like bindings that become available to you inside the test
;;      case.

(define-syntax test-case
  (syntax-rules (warn)

        ;; NOTE: these rules are order dependent!

    ;; support the optional let bindings with warning syntax
    ((_ testname destname escape (warn warning) ((name value) ...) clauses ...)
    ((lambda (name ...)
        (let (  (warnobj warning)
                        (tname testname)
                        (destname (test:make-destructor)))
          (let ((test-result
                 (call-with-current-continuation
                  (lambda (escape)
                    (test:eval-expectations clauses ...)))))
                ;; call the destructor to get rid of anything the user didn't want
                (destructor-activate! destname)
                (let ((stripped-test-result (test:strip-ignored-results test-result)))
                        ;; If the user exited via the terminate mechanism, then record this
                        ;; fact with a real terminate node in the tree.
                (cond ((terminate? stripped-test-result)
                                (set! test-result
                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
                        ;; return the typed list for this kind of test result
                (test:make-test-case-result (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result warnobj))))) value ...))

    ;; support the optional let bindings
    ((_ testname destname escape ((name value) ...) clauses ...)
     ((lambda (name ...)
        (let ((tname testname) (destname (test:make-destructor)))
          (let ((test-result
                 (call-with-current-continuation
                  (lambda (escape)
                    (test:eval-expectations clauses ...)))))
                ;; call the destructor to get rid of anything the user didn't want
                (destructor-activate! destname)
                (let ((stripped-test-result (test:strip-ignored-results test-result)))
                        ;; If the user exited via the terminate mechanism, then record this
                        ;; fact with a real terminate node in the tree.
                (cond ((terminate? stripped-test-result)
                                (set! stripped-test-result
                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
                        ;; return the typed list for this kind of test result
                (test:make-test-case-result
                                (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result))))) value ...))


    ;; no let bindings with warning syntax
    ((_ testname destname escape (warn warning) clauses ...)
     (let ((warnobj warning)
                        (tname testname)
                        (destname (test:make-destructor)))
       (let ((test-result
              (call-with-current-continuation
               (lambda (escape)
                        (test:eval-expectations clauses ...)))))
                ;; call the destructor to get rid of anything the user didn't want
                (destructor-activate! destname)
                (let ((stripped-test-result (test:strip-ignored-results test-result)))
                        ;; If the user exited via the terminate mechanism, then record this
                        ;; fact with a real terminate node in the tree.
                (cond ((terminate? stripped-test-result)
                                (set! stripped-test-result
                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
                        ;; return the typed list for this kind of test result
                        (test:make-test-case-result
                                (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result warnobj)))))

    ;; no let bindings
    ((_ testname destname escape clauses ...)
     (let ((tname testname)
                        (destname (test:make-destructor)))
       (let ((test-result ;; invoke the expectations...
              (call-with-current-continuation
               (lambda (escape)
                        (test:eval-expectations clauses ...)))))
                ;; call the destructor to get rid of anything the user didn't want
                (destructor-activate! destname)
                (let ((stripped-test-result (test:strip-ignored-results test-result)))
                        ;; If the user exited via the terminate mechanism, then record this
                        ;; fact with a real terminate node in the tree.
                (cond ((terminate? stripped-test-result)
                                (set! stripped-test-result
                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
                        ;; return the typed list for this kind of test result
                        (test:make-test-case-result
                                (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result)))))))

;; this is the definition of the macro test-package:
;; (test-package DESC DEST-NAME TERM-NAME TESTCASES|TESTPACKAGES|EXPECTATIONS)
;; (test-package DESC DEST-NAME TERM-NAME (warn WARNING) TESTCASES|TESTPACKAGES|EXPECTATIONS)
;; (test-package DESC DEST-NAME TERM-NAME (FORMALS) TESTCASES|TESTPACKAGES|EXPECTATIONS)
;; (test-package DESC DEST-NAME TERM-NAME (warn WARNING) (FORMALS) TESTCASES|TESTPACKAGES|EXPECTATIONS)
;; DESC is an object (usually a string) that explains what the test-case is.
;; DEST-NAME is the name of the destructor object provided for you in the
;;      scope of the test-case(allows you to clean things up in case of
;;      termination). The destructor object automatically when the expectations
;;      have finished for any reason.
;; TERM-NAME is the name of the escape function you must pass to (terminate ...)
;;      when you want to abort the test case.
;; TESTCASES|TESTPACKAGES|EXPECTATIONS is a list of test packages(they can nest)
;;      or test cases or expectations. An expectation used bare in a test package
;;      DOES NOT have the auto short circut behaviour that it would in a test-case.
;;      Usually expectations are not placed bare into packages. However they
;;      can be, and the result tree walking code wil have to deal with it specially.
;; WARNING is a string(actually any type, but usually string) message that
;;      expains that something isn't quite right or there are special circumstances
;;      to something.
;; FORMALS are let-like bindings that become available to you inside the test
;;      package.
(define-syntax test-package
  (syntax-rules (warn)

        ;; NOTE: these rules are order dependent!

    ;; support the optional let bindings with warning syntax
    ((_ packagename destname escape (warn warning) ((name value) ...) clauses ...)
     ((lambda (name ...)
        (let ((warnobj warning)
                        (pname packagename) (destname (test:make-destructor)))
          (let ((test-result
                 (call-with-current-continuation
                  (lambda (escape)
                    (test:eval-lr clauses ...)))))
                ;; call the destructor to get rid of anything the user didn't want
                (destructor-activate! destname)
                (let ((stripped-test-result (test:strip-ignored-results test-result)))
                        ;; If the user exited via the terminate mechanism, then record this
                        ;; fact with a real terminate node in the tree.
                (cond ((terminate? stripped-test-result)
                                (set! stripped-test-result
                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
                        ;; return the typed list for this kind of test result
                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result warnobj))))) value ...))

    ;; support the optional let bindings
    ((_ packagename destname escape ((name value) ...) clauses ...)
     ((lambda (name ...)
        (let ((pname packagename) (destname (test:make-destructor)))
          (let ((test-result
                 (call-with-current-continuation
                  (lambda (escape)
                    (test:eval-lr clauses ...)))))
                ;; call the destructor to get rid of anything the user didn't want
                (destructor-activate! destname)
                (let ((stripped-test-result (test:strip-ignored-results test-result)))
                        ;; If the user exited via the terminate mechanism, then record this
                        ;; fact with a real terminate node in the tree.
                (cond ((terminate? stripped-test-result)
                                (set! stripped-test-result
                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
                        ;;      return the typed list for this kind of test result
                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result))))) value ...))

    ;; no let bindings with warning syntax
    ((_ packagename destname escape (warn warning) clauses ...)
     (let (     (warnobj warning)
                        (pname packagename) (destname (test:make-destructor)))
       (let ((test-result
              (call-with-current-continuation
               (lambda (escape)
                        (test:eval-lr clauses ...)))))
                ;; call the destructor to get rid of anything the user didn't want
                (destructor-activate! destname)
                (let ((stripped-test-result (test:strip-ignored-results test-result)))
                        ;; If the user exited via the terminate mechanism, then record this
                        ;; fact with a real terminate node in the tree.
                (cond ((terminate? stripped-test-result)
                                (set! stripped-test-result
                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
                        ;; return the typed list for this kind of test result
                        (test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result warnobj)))))

    ;; no let bindings
    ((_ packagename destname escape clauses ...)
     (let ((pname packagename) (destname (test:make-destructor)))
       (let ((test-result
              (call-with-current-continuation
               (lambda (escape)
                        (test:eval-lr clauses ...)))))
                ;; call the destructor to get rid of anything the user didn't want
                (destructor-activate! destname)
                (let ((stripped-test-result (test:strip-ignored-results test-result)))
                        ;; If the user exited via the terminate mechanism, then record this
                        ;; fact with a real terminate node in the tree.
                (cond ((terminate? stripped-test-result)
                                (set! stripped-test-result
                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
                        ;; return the typed list for this kind of test result
                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result)))))))

;;;;;;;;;;;;;;;;;;
;; evaluate the side effect expressions and return an ignored result no matter
;; what happens. Maybe some other day I might specialize this for some purpose.
;; (side-effect EXP)
(define-syntax side-effect
        (syntax-rules ()
        ((_ clauses ...)
                (begin clauses ...
                        (test:make-ignore-result)))))

;; the macro the user uses to create the todo
;; (todo MESSAGE)
;; (todo MESSAGE (warn WARNING))
(define-syntax todo
        (syntax-rules (warn)

        ;; with warning syntax
        ((_ message (warn warning))
                (let ((warnobj warning) (msg message))
                        (test:make-todo-result msg warnobj)))

        ;; without warning syntax
        ((_ message)
                (let ((msg message))
                        (test:make-todo-result msg)))))

;; the macro the user uses to create the gloss
;; (gloss MESSAGE)
;; (gloss MESSAGE (warn WARNING))
(define-syntax gloss
        (syntax-rules (warn)

        ;; with warning syntax
        ((_ message (warn warning))
                (let ((warnobj warning) (msg message))
                        (test:make-gloss-result msg warnobj)))

        ;; without warning syntax
        ((_ message)
                (let ((msg message))
                        (test:make-gloss-result msg)))))

;; the macro the user uses to create a skipped entity. The clauses that
;; come in the skip are just totally removed and not even computed by the
;; macro.
;; (skip MESSAGE clauses ...)
;; (skip MESSAGE (warn WARNING) clauses ...)
(define-syntax skip
        (syntax-rules (warn)

        ;; with warning syntax
        ((_ message (warn warning) clauses ...) ;; ignore the clauses
                (let ((warnobj warning) (msg message))
                        (test:make-skip-result msg warnobj)))

        ;; without warning syntax
        ((_ message clauses ...) ;; ignore the clauses
                (let ((msg message))
                        (test:make-skip-result msg)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-zero: Expect a value that will be exactly zero
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-zero
  (syntax-rules (warn)

        ;; with optional warning syntax
        ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-zero message value)))
                 (test:make-expect-result result "zero" message 'val value warnobj))))

        ;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-zero message value)))
                 (test:make-expect-result result "zero" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-nonzero: Expect a value to be non-zero
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-nonzero
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-nonzero message value)))
                (test:make-expect-result result "nonzero" message 'val value warnobj))))

        ;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-nonzero message value)))
                (test:make-expect-result result "nonzero" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-true: Expect a value to be #t
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-true
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-true message value)))
                (test:make-expect-result result "true" message 'val value warnobj))))

        ;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-true message value)))
                (test:make-expect-result result "true" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-false: Expect a value to be #f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-false
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-false message value)))
                (test:make-expect-result result "false" message 'val value warnobj))))

        ;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-false message value)))
                (test:make-expect-result result "false" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-eq: Expect the eq? relation to hold between val and arg
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-eq
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((expect-eq msg (warn warning) val arg)
     (let ((warnobj warning) (message msg) (value val) (argument arg))
       (let ((result (test:_expect-eq message value argument)))
                (test:make-expect-equivalence-result result "eq" message
                        value 'arg argument warnobj))))

        ;; without optional warning syntax
    ((expect-eq msg val arg)
     (let ((message msg) (value val) (argument arg))
       (let ((result (test:_expect-eq message value argument)))
                (test:make-expect-equivalence-result result "eq" message
                        value 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-eqv: Expect the eqv? relation to hold between val and arg
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-eqv
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val arg)
     (let ((warnobj warning) (message msg) (value val) (argument arg))
       (let ((result (test:_expect-eqv message value argument)))
                (test:make-expect-equivalence-result result "eqv" message
                        value 'arg argument warnobj))))

        ;; without optional warning syntax
    ((_ msg val arg)
     (let ((message msg) (value val) (argument arg))
       (let ((result (test:_expect-eqv message value argument)))
                (test:make-expect-equivalence-result result "eqv" message
                        value 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-equal: Expect the equal? relation to hold between val and arg
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-equal
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val arg)
     (let ((warnobj warning) (message msg) (value val) (argument arg))
       (let ((result (test:_expect-equal message value argument)))
                (test:make-expect-equivalence-result result "equal" message
                        value 'arg argument warnobj))))

        ;; without optional warning syntax
    ((_ msg val arg)
     (let ((message msg) (value val) (argument arg))
       (let ((result (test:_expect-equal message value argument)))
                (test:make-expect-equivalence-result result "equal" message
                        value 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-near: Expect a value within a certain tolerance
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-near
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val tol arg)
     (let (     (warnobj warning) (message msg) (value val) (tolerance tol)
                        (argument arg))
       (let ((result (test:_expect-near message value tolerance argument)))
                (test:make-expect-tolerance-result result "near" message
                        value tol 'arg argument warnobj))))

        ;; without optional warning syntax
    ((_ msg val tol arg)
     (let ((message msg) (value val) (tolerance tol) (argument arg))
       (let ((result (test:_expect-near message value tolerance argument)))
                (test:make-expect-tolerance-result result "near" message
                        value tol 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-positive: Expect a number to be positive
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-positive
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-positive message value)))
                (test:make-expect-result result "positive" message 'val value warnobj))))

        ;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-positive message value)))
                (test:make-expect-result result "positive" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-negative: Expect a number to be negative.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-negative
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-negative message value)))
                (test:make-expect-result result "negative" message 'val value warnobj))))

        ;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-negative message value)))
                (test:make-expect-result result "negative" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-not-false: Expect a non-false result.
;;
;; Could be done with (expect-true MSG (not (not VAL)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-not-false
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-not-false message value)))
                (test:make-expect-result result "not-false" message 'val value warnobj))))

        ;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-not-false message value)))
                (test:make-expect-result result "not-false" message 'val value))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-values: Expect a multi-valued result.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-values
  (syntax-rules (warn)

; value probably not reasonable output for message - need something else

        ;; with optional warning syntax
    ((_ msg (warn warning) val arg)
     (let ((warnobj warning) (message msg) (value val) (argument (receive arg)))
       (let ((result (test:_expect-values message value argument)))
                (test:make-expect-equivalence-result result "values" message
                        value 'arg argument warnobj))))

        ;; without optional warning syntax
    ((_ msg val arg)
     (let ((message msg) (value val) (argument (receive arg)))
       (let ((result (test:_expect-values message value argument)))
                (test:make-expect-equivalence-result result "values" message
                        value 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-values support
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax test:expect-values-test
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val arg name test)
     (let ((warnobj warning) (message msg) (value val) (argument (receive arg)))
       (let ((result (test message value argument)))
                (test:make-expect-equivalence-result result name message
                        value 'arg argument warnobj))))

        ;; without optional warning syntax
    ((_ msg val arg test)
     (let ((message msg) (value val) (argument (receive arg)))
       (let ((result (test message value argument)))
                (test:make-expect-equivalence-result result name message
                        value 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-values-eq: Expect a multi-valued result.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-values-eq
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val arg)
        (test:expect-values-test msg (warn warning) val arg test:_expect-values-eq "values-eq"))

        ;; without optional warning syntax
    ((_ msg val arg)
        (test:expect-values-test msg val arg test:_expect-values-eq "values-eq"))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-values-eq?: Expect a multi-valued result.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-values-eqv
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val arg)
        (test:expect-values-test msg (warn warning) val arg test:_expect-values-eqv "values-eqv"))

        ;; without optional warning syntax
    ((_ msg val arg)
        (test:expect-values-test msg val arg test:_expect-values-eqv "values-eqv"))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-values-equal: Expect a multi-valued result.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-values-equal
  (syntax-rules (warn)

        ;; with optional warning syntax
    ((_ msg (warn warning) val arg)
        (test:expect-values-test msg (warn warning) val arg test:_expect-values-equal "values-equal"))

        ;; without optional warning syntax
    ((_ msg val arg)
        (test:expect-values-test msg val arg test:_expect-values-equal "values-equal"))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-exception support.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax test:gen-exception-property-test
        (syntax-rules (and or not)

                ((_ EXP KIND-KEY ()) #t)

                ((_ EXP KIND-KEY (and PROP-EXPR PROP-EXPRS ...))
                        (and (test:gen-exception-property-test EXP KIND-KEY PROP-EXPR)
                                (test:gen-exception-property-test EXP KIND-KEY (PROP-EXPRS ...))))

                ((_ EXP KIND-KEY (or PROP-EXPR PROP-EXPRS ...))
                        (or (test:gen-exception-property-test EXP KIND-KEY PROP-EXPR)
                                (test:gen-exception-property-test EXP KIND-KEY (PROP-EXPRS ...))))

                ((_ EXP KIND-KEY (not PROP-EXPR))
                        (not (test:gen-exception-property-test EXP KIND-KEY PROP-EXPR)))

                ((_ EXP KIND-KEY (BIN-OP PROP-KEY VAL))
                        (BIN-OP (test:gen-exception-property-test EXP KIND-KEY PROP-KEY) VAL))

                ((_ EXP KIND-KEY (PROP-KEY VAL))
                        (equal? (test:gen-exception-property-test EXP KIND-KEY PROP-KEY) VAL))

                ((_ EXP KIND-KEY (PROP-KEY PROP-KEYS ...))
                        (and (test:gen-exception-property-test EXP KIND-KEY PROP-KEY)
                                (test:gen-exception-property-test EXP KIND-KEY (PROP-KEYS ...))))

                ((_ EXP KIND-KEY PROP-KEY)
                        (test:has-condition-property
                                (condition-property-accessor 'KIND-KEY 'PROP-KEY) EXP))))

(define-syntax test:gen-exception-test
        (syntax-rules (and or not property)

                ((_ EXP ()) #t)

                ((_ EXP (and COND-EXPR COND-EXPRS ...))
                        (and (test:gen-exception-test EXP COND-EXPR)
                                (test:gen-exception-test EXP (COND-EXPRS ...))))

                ((_ EXP (or COND-EXPR COND-EXPRS ...))
                        (or (test:gen-exception-test EXP COND-EXPR)
                                (test:gen-exception-test EXP (COND-EXPRS ...))))

                ((_ EXP (not COND-EXPR))
                        (not (test:gen-exception-test EXP COND-EXPR)))

                ((_ EXP (property KIND-KEY PROP-EXPR ...))
                        (and (test:gen-exception-test EXP KIND-KEY)
                                (test:gen-exception-property-test EXP KIND-KEY (PROP-EXPR ...))))

                ((_ EXP (KIND-KEY KIND-KEYS ...))
                        (and (test:gen-exception-test EXP KIND-KEY)
                                (test:gen-exception-test EXP (KIND-KEYS ...))))

                ((_ EXP KIND-KEY) ((condition-predicate 'KIND-KEY) EXP))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-exception: Expect an exception.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax expect-exception
        (syntax-rules (warn)

                ;; with optional warning syntax
                ((_ msg (warn warning) exn arg)
                         (let ([warnobj warning] [message msg] [argument
                                (call/cc (lambda (k)
                                        (with-exception-handler
                                                (lambda (the-exception) (k (test:gen-exception-test the-exception exn)))
                                                (lambda () (k arg)))))])
                                (let ((result (test:_expect-exception message 'exn argument)))
                                        (test:make-expect-equivalence-result result "exception" message 'exn 'arg argument warnobj))))

                ;; without optional warning syntax
                ((_ msg exn arg)
                         (let ([message msg] [argument
                                (call/cc (lambda (k)
                                        (with-exception-handler
                                                (lambda (the-exception) (k (test:gen-exception-test the-exception exn)))
                                                (lambda () (k arg)))))])
                                (let ((result (test:_expect-exception message 'exn argument)))
                                        (test:make-expect-equivalence-result result "exception" message 'exn 'arg argument))))))


;;;;;;;;;;;;;;;;;;
;; This next macro and subsequent invocations describe the API by which you
;; may inspect a statistics object.
;;;;;;;;;;;;;;;;;;

;; Allow me to define all of the stats API functions that interact
;; with the black box statistics object. In this case, the black box is
;; a vector.
(define-syntax test:gen-stat-API-func
(syntax-rules (set incr decr ref)
        ((_ set fname idx)
                (define fname
                        (lambda (statobj val)
                                (vector-set! statobj val idx))))
        ((_ incr fname idx)
                (define fname
                        (lambda (statobj)
                                (vector-set! statobj idx (+ (vector-ref statobj idx) 1)))))
        ((_ decr fname idx)
                (define fname
                        (lambda (statobj)
                                (vector-set! statobj idx (- (vector-ref statobj idx) 1)))))
        ((_ ref fname idx)
                (define fname
                        (lambda (statobj)
                                (vector-ref statobj idx))))))