From 9a468dd9d018b67f0339c7ddcb3f1cc743d9e92f Mon Sep 17 00:00:00 2001 From: Jay McCarthy 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 or ; 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))