From ea5a6fc91c86d96d81ab9b50b6773bfa9f597b43 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Fri, 7 Jan 2011 09:34:12 -0600
Subject: [PATCH] Fixes exception handling in randomized tests

---
 .../redex/examples/delim-cont/model-impl.rkt  | 34 +++++++------------
 .../examples/delim-cont/randomized-tests.rkt  | 28 ++++++++-------
 2 files changed, 28 insertions(+), 34 deletions(-)

diff --git a/collects/redex/examples/delim-cont/model-impl.rkt b/collects/redex/examples/delim-cont/model-impl.rkt
index 865288d05d..2bb4f8f625 100644
--- a/collects/redex/examples/delim-cont/model-impl.rkt
+++ b/collects/redex/examples/delim-cont/model-impl.rkt
@@ -7,8 +7,7 @@
                      [_print print]
                      [_cons cons]
                      [_set! set!]
-                     [_zero? zero?])
-         (struct-out runtime-error) raise-runtime-error first-error)
+                     [_zero? zero?]))
 
 (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))
-(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))
\ No newline at end of file
+(define (_cons x xs)
+  (if (list? xs)
+      (cons x xs)
+      (raise-type-error 'cons "list?" 1 x xs)))
+
+(define (_print n)
+  (if (number? n)
+      (begin (print n) #f)
+      (raise-type-error 'print "number" n)))
\ No newline at end of file
diff --git a/collects/redex/examples/delim-cont/randomized-tests.rkt b/collects/redex/examples/delim-cont/randomized-tests.rkt
index b556d7b09c..a9974135bc 100644
--- a/collects/redex/examples/delim-cont/randomized-tests.rkt
+++ b/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)])
-        (define result
-          (with-handlers ([runtime-error? void])
-            (letrec ,s ,e)))
-        (match (first-error)
-          [(box #f) result]
-          [(box err) (raise err)]))]
+     `(let* ([previous-error #f]
+             [result 
+              (with-handlers ([exn:fail? void])
+                (call-with-exception-handler
+                 (λ (exn)
+                   (when (and (exn:fail? exn) (not previous-error))
+                     (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)]
-                        [runtime-error?
+        (with-handlers ([exn:fail?
                          (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))