From 9a468dd9d018b67f0339c7ddcb3f1cc743d9e92f Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Wed, 17 Feb 2010 16:04:13 +0000
Subject: [PATCH] Fixing error message re Robby and rearranging tests a little

svn: r18117
---
 collects/plai/mutator.ss                            | 13 +++++++++++--
 collects/tests/plai/gc/bad-mutators/void-app.ss     |  4 ++++
 .../{ => gc/good-collectors}/no-compact-cheat.ss    |  0
 collects/tests/plai/gc/run-test.ss                  | 10 ++++++++++
 collects/tests/plai/test-random-mutator.ss          |  1 +
 5 files changed, 26 insertions(+), 2 deletions(-)
 create mode 100644 collects/tests/plai/gc/bad-mutators/void-app.ss
 rename collects/tests/plai/{ => gc/good-collectors}/no-compact-cheat.ss (100%)

diff --git a/collects/plai/mutator.ss b/collects/plai/mutator.ss
index 259629b6d4..21d307c251 100644
--- a/collects/plai/mutator.ss
+++ b/collects/plai/mutator.ss
@@ -208,12 +208,12 @@
      (with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)])
        (if (syntax-parameter-value #'mutator-tail-call?)
            ; If this call is in tail position, we will not need access to its environment when it returns.
-           (syntax/loc stx ((deref fe) ae ...))
+           (syntax/loc stx ((deref-proc fe) ae ...))
            ; If this call is not in tail position, we make the environment at the call site
            ; reachable.
            #`(with-continuation-mark gc-roots-key 
                (list (make-env-root env-id) ...)
-               #,(syntax/loc stx ((deref fe) ae ...)))))]))
+               #,(syntax/loc stx ((deref-proc fe) ae ...)))))]))
 (define-syntax mutator-quote
   (syntax-rules ()
     [(_ (a . d))
@@ -455,6 +455,15 @@
     [(location? proc/loc) (collector:deref proc/loc)]
     [else (error 'deref "expected <location?> or <procedure?>; received ~a" proc/loc)]))
 
+(define (deref-proc proc-or-loc)
+  (define v 
+    (with-handlers ([exn? (lambda (x) 
+                            (error 'procedure-application "expected procedure, given something else"))])
+      (deref proc-or-loc)))
+  (if (procedure? v)
+      v
+      (error 'procedure-application "expected procedure, given ~e" v)))
+
 (define (gc->scheme loc)
   (define-struct an-unset ())
   (define unset (make-an-unset))
diff --git a/collects/tests/plai/gc/bad-mutators/void-app.ss b/collects/tests/plai/gc/bad-mutators/void-app.ss
new file mode 100644
index 0000000000..2e2e9e8a6f
--- /dev/null
+++ b/collects/tests/plai/gc/bad-mutators/void-app.ss
@@ -0,0 +1,4 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/no-compact-cheat.ss" 100)
+(define x (cons 1 2))
+((set-first! x 2) 1)
\ No newline at end of file
diff --git a/collects/tests/plai/no-compact-cheat.ss b/collects/tests/plai/gc/good-collectors/no-compact-cheat.ss
similarity index 100%
rename from collects/tests/plai/no-compact-cheat.ss
rename to collects/tests/plai/gc/good-collectors/no-compact-cheat.ss
diff --git a/collects/tests/plai/gc/run-test.ss b/collects/tests/plai/gc/run-test.ss
index 5a09041d32..28cfb602ce 100644
--- a/collects/tests/plai/gc/run-test.ss
+++ b/collects/tests/plai/gc/run-test.ss
@@ -14,7 +14,17 @@
   (parameterize ([current-namespace (make-base-empty-namespace)])
     (dynamic-require m #f)))
 
+(define run-good? (make-parameter #f))
+
+(command-line #:program "run-test"
+              #:once-each ["-g" "Enable running good mutators" (run-good? #t)])
+
 (test
+ (if (run-good?)
+     (for ([m (in-directory (build-path here "good-mutators") #rx"ss$")])
+       (test
+        (test-mutator m)))
+     (void))
  (for ([m (in-directory (build-path here "bad-mutators") #rx"ss$")])
    (test
     (test-mutator m) =error> #rx"")))
\ No newline at end of file
diff --git a/collects/tests/plai/test-random-mutator.ss b/collects/tests/plai/test-random-mutator.ss
index 2e1fa0e0ea..6e88cf3cc5 100644
--- a/collects/tests/plai/test-random-mutator.ss
+++ b/collects/tests/plai/test-random-mutator.ss
@@ -25,6 +25,7 @@
                                                  (find-relative-path 
                                                   (simple-form-path tmpfile)
                                                   (build-path (simple-form-path here)
+                                                              "gc" "good-collectors"
                                                               "no-compact-cheat.ss")))
                                                100))
         (for-each (λ (exp) (pretty-print exp port)) exps))