Fixes exception handling in randomized tests

collects/redex/examples/delim-cont/model-impl.rkt

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

collects/redex/examples/delim-cont/randomized-tests.rkt

@@ -2,7 +2,6 @@
 
 (require "grammar.ss" 
          "reduce.rkt"
-         (only-in "model-impl.rkt" runtime-error runtime-error?)
          (except-in redex/reduction-semantics plug)
          racket/runtime-path)
 
@@ -91,13 +90,18 @@
 (define impl-program
   (match-lambda
     [`(<> ,s [] ,e)
-     `(parameterize ([first-error (box #f)])
+     `(let* ([previous-error #f]
-        (define result
+             [result 
-          (with-handlers ([runtime-error? void])
+              (with-handlers ([exn:fail? void])
-            (letrec ,s ,e)))
+                (call-with-exception-handler
-        (match (first-error)
+                 (λ (exn)
-          [(box #f) result]
+                   (when (and (exn:fail? exn) (not previous-error))
-          [(box err) (raise err)]))]
+                     (set! previous-error exn))
+                   exn)
+                 (λ () (letrec ,s ,e))))])
+            (if (exn:fail? previous-error)
+                (raise previous-error)
+                result))]
     [e e]))
 
 (define-runtime-module-path model-impl "model-impl.rkt")
@@ -115,12 +119,12 @@
     (λ (test)
       (define output (open-output-string))
       (define result
-        (with-handlers ([exn:fail? (compose error exn-message)]
+        (with-handlers ([exn:fail?
-                        [runtime-error?
                          (match-lambda
-                           [(runtime-error '% "non-procedure" _)
+                           [(exn:fail (regexp "%: expected argument of type <non-procedure>") _)
                             (bad-test "procedure as tag")]
-                           [e (error e)])])
+                           [(exn:fail m _)
+                            (error m)])])
           (parameterize ([current-output-port output])
             (eval test ns))))
       (if (or (error? result) (bad-test? result))