suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Changes the randomized tests to watch for the first exception.

Browse Source 
The particular exception raised is important. We don't want a later
one raised by a dynamic-wind post-thunk.
This commit is contained in:
Casey Klein 2010-12-30 10:10:06 -06:00
parent de8b1bc101
commit 579cb022bd
2 changed files with 30 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/redex/examples/delim-cont/model-impl.rkt
View File

@ -7,7 +7,8 @@
[_print print]
[_cons cons]
[_set! set!]
[_zero? zero?]))
[_zero? zero?])
(struct-out runtime-error) raise-runtime-error first-error)
(define tag
(let ([tags (make-hash)])
@ -27,7 +28,7 @@
[(list? v) (andmap comparable? v)]
[else #t]))
(tag v)
(raise-type-error '% "non-procedure" v)))
(raise-runtime-error '% "non-procedure" v)))
(let ([h handler])
(λ (x) (h x)))))
@ -55,22 +56,31 @@
(case v1
[(#t) e2]
[(#f) e3]
[else (raise-type-error 'if "#t or #f" v1)])))
[else (raise-runtime-error 'if "#t or #f" v1)])))
(define (_+ x y) (+ x y))
(define (_print n)
(if (number? n)
(begin (print n) #f)
(raise-type-error 'print "number" n)))
(raise-runtime-error 'print "number" n)))
(define (_cons x xs)
(if (list? xs)
(cons x xs)
(raise-type-error 'cons "list?" 1 x xs)))
(raise-runtime-error 'cons "list?" xs)))
(define-syntax-rule (_set! x e)
(begin (set! x e) #f))
(define (_zero? x)
(equal? 0 x))
(equal? 0 x))
(define first-error (make-parameter #f))
(struct runtime-error (primitive expected given) #:prefab)
(define (raise-runtime-error . details)
(define error (apply runtime-error details))
(when (first-error)
(unless (unbox (first-error))
(set-box! (first-error) error)))
(raise error))

21
collects/redex/examples/delim-cont/randomized-tests.rkt
View File

@ -2,6 +2,7 @@
(require "grammar.ss"
"reduce.rkt"
(only-in "model-impl.rkt" runtime-error runtime-error?)
(except-in redex/reduction-semantics plug)
racket/runtime-path)
@ -54,7 +55,13 @@
(define impl-program
(match-lambda
[`(<> ,s [] ,e)
`(letrec ,s ,e)]
`(parameterize ([first-error (box #f)])
(define result
(with-handlers ([runtime-error? void])
(letrec ,s ,e)))
(match (first-error)
[(box #f) result]
[(box err) (raise err)]))]
[e e]))
(define-runtime-module-path model-impl "model-impl.rkt")
@ -72,12 +79,12 @@
(λ (test)
(define output (open-output-string))
(define result
(with-handlers ([exn:fail?
(λ (e)
(match (exn-message e)
[(regexp #rx"%: expected argument of type <non-procedure>")
(bad-test "procedure as tag")]
[_ (error e)]))])
(with-handlers ([exn:fail? (compose error exn-message)]
[runtime-error?
(match-lambda
[(runtime-error '% "non-procedure" _)
(bad-test "procedure as tag")]
[e (error e)])])
(parameterize ([current-output-port output])
(eval test ns))))
(if (or (error? result) (bad-test? result))