diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss index 29bb105d8e..fac7f9de60 100644 --- a/collects/tests/mzscheme/beg-adv.ss +++ b/collects/tests/mzscheme/beg-adv.ss @@ -95,7 +95,8 @@ (htdp-test 19 'cond (cond [(zero? 10) 0] [else 19])) (htdp-err/rt-test (cond [#f 10]) exn:fail?) ;; Should it be a different exception? -(htdp-err/rt-test (cond [1 10])) +(define rx:not-true-or-false "not true or false") +(htdp-err/rt-test (cond [1 10]) rx:not-true-or-false) (htdp-syntax-test #'if) (htdp-syntax-test #'(if)) @@ -103,22 +104,22 @@ (htdp-syntax-test #'(if #t 1)) (htdp-syntax-test #'(if #t 1 2 3)) -(htdp-err/rt-test (if 1 2 3)) +(htdp-err/rt-test (if 1 2 3) rx:not-true-or-false) (htdp-syntax-test #'and) (htdp-syntax-test #'(and)) (htdp-syntax-test #'(and #t)) -(htdp-err/rt-test (and 1 #t)) -(htdp-err/rt-test (and #t 1)) +(htdp-err/rt-test (and 1 #t) rx:not-true-or-false) +(htdp-err/rt-test (and #t 1) rx:not-true-or-false) (htdp-test #f 'ok-and (and #t #f 1)) (htdp-syntax-test #'or) (htdp-syntax-test #'(or)) (htdp-syntax-test #'(or #t)) -(htdp-err/rt-test (or 1 #f)) -(htdp-err/rt-test (or #f 1)) +(htdp-err/rt-test (or 1 #f) rx:not-true-or-false) +(htdp-err/rt-test (or #f 1) rx:not-true-or-false) (htdp-test #t 'ok-or (or #f #t 1)) (htdp-test #t 'empty? (empty? empty)) diff --git a/collects/tests/mzscheme/beginner.ss b/collects/tests/mzscheme/beginner.ss index e9b0930298..41f2bdae5b 100644 --- a/collects/tests/mzscheme/beginner.ss +++ b/collects/tests/mzscheme/beginner.ss @@ -1,6 +1,7 @@ ;; Basic checks for the beginner language. Error messages really -;; should be inspected manually. +;; should be inspected manually, but there's some support for +;; automatic checking. ;; Limitations of this test suite: ;; - It doesn't check reader-level parameterization, such as use of quotes @@ -13,6 +14,40 @@ ;; See also htdp-image.ss, which must be loaded into MrEd (but is in this ;; directory anyway) +;; Tests that apply to all languages go in beg-adv.ss. +;; Tests that apply only to beginner through intermediate go in beg-intm.ss, +;; and so on. + +;; Writing tests: +;; +;; (htdp-test ) +;; checks a run-time result; is +;; an expression evaluated at the top level, +;; and is put into a module and evaluated; +;; is usually a symbol, and it is used only for +;; naming the test in output +;; +;; (htdp-err/rt-test ) +;; (htdp-err/rt-test ) +;; (htdp-err/rt-test ) +;; checks for a run-time error by putting into a +;; module and evaluting; if is supplied, the +;; predicate must produce #t for the resulting exception; +;; if is supplied, the exception +;; message string must match the regexp +;; +;; (htdp-syntax-test #') +;; (htdp-syntax-test #' ) +;; check for a syntax error, putting into a module; +;; if is supplied, the syntax error +;; message must match the regexp +;; +;; (htdp-top ) +;; imperatively adds an expression to be included into +;; test modules +;; (htdp-top-pop ) +;; removes the last added expressions +;; (load-relative "loadtest.ss") diff --git a/collects/tests/mzscheme/htdp-test.ss b/collects/tests/mzscheme/htdp-test.ss index 2b5474765e..3571d5f6c7 100644 --- a/collects/tests/mzscheme/htdp-test.ss +++ b/collects/tests/mzscheme/htdp-test.ss @@ -26,17 +26,22 @@ [(_ expect f . args) #'(do-htdp-test #'(test expect f . args) #f #f)])) +(define (htdp-string-to-pred exn?/rx) + (if (string? exn?/rx) + (lambda (x) + (regexp-match exn?/rx (exn-message x))) + exn?/rx)) + (define-syntax (htdp-err/rt-test stx) (syntax-case stx () [(_ expr) #'(do-htdp-test #'expr #f exn:application:type?)] [(_ expr exn?) - #'(do-htdp-test #'expr #f exn?)])) + #'(do-htdp-test #'expr #f (htdp-string-to-pred exn?))])) (define (htdp-error-test stx) (do-htdp-test stx #t #f)) - (module helper mzscheme (define-syntax (module-begin stx) (syntax-case stx ()