From 38f5823a5945962da1ca72797d02c3e4dc249110 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 9 Mar 2013 16:05:32 -0600 Subject: [PATCH] adjust plai's gc2 language to use roots as the arguments to gc:cons and gc:closure instead of passing locs This enables the important change, namely that get-root-set no longer returns roots corresponding to the arguments of the allocation function that we're in the middle of. This means that a common error students have (forgetting to chase the 'hd' and 'tl' pointers in their GC) is harder to make now, since get-root-set never contains those locations as roots. (In the past you would have had to write some pretty non-obvious mutator program to get that behavior.) --- collects/plai/gc2/collector.rkt | 4 +- collects/plai/gc2/mutator.rkt | 81 ++++++++++++++++--- .../plai/gc2/private/collector-exports.rkt | 10 ++- collects/plai/gc2/private/gc-core.rkt | 66 +++++++-------- collects/plai/scribblings/collector2.scrbl | 77 +++++++++++------- .../gc2/good-collectors/good-collector.rkt | 32 ++++---- .../gc2/good-collectors/trivial-collector.rkt | 19 ++--- collects/tests/plai/gc2/roots-test.rkt | 32 ++++---- collects/tests/plai/gc2/run-test.rkt | 2 +- 9 files changed, 195 insertions(+), 128 deletions(-) diff --git a/collects/plai/gc2/collector.rkt b/collects/plai/gc2/collector.rkt index 90e64e3eae..5077ecc304 100644 --- a/collects/plai/gc2/collector.rkt +++ b/collects/plai/gc2/collector.rkt @@ -48,8 +48,8 @@ (provide/contract (gc:deref (location? . -> . heap-value?))) (provide/contract (gc:alloc-flat (heap-value? . -> . location?))) - (provide/contract (gc:cons (location? location? . -> . location?))) - (provide/contract (gc:closure (closure-code? (vectorof location?) . -> . location?))) + (provide/contract (gc:cons (root? root? . -> . location?))) + (provide/contract (gc:closure (closure-code? (listof root?) . -> . location?))) (provide/contract (gc:closure-code-ptr (location? . -> . closure-code?))) (provide/contract (gc:closure-env-ref (location? integer? . -> . location?))) diff --git a/collects/plai/gc2/mutator.rkt b/collects/plai/gc2/mutator.rkt index a85c705e8f..957d7605c7 100644 --- a/collects/plai/gc2/mutator.rkt +++ b/collects/plai/gc2/mutator.rkt @@ -36,7 +36,7 @@ [mutator-lambda λ] (mutator-app #%app) (mutator-datum #%datum) - (collector:cons cons) + (mutator-cons cons) (collector:first first) (collector:rest rest) (mutator-quote quote) @@ -118,6 +118,33 @@ (yes! fe))]) (mutator-begin e ...))])) +(define mutator-cons + (let ([cons + (λ (hd tl) + (define roots (compute-current-roots)) + (define-values (hd-roots no-hd-roots) + (partition (λ (x) (= hd (read-root x))) roots)) + (define-values (tl-roots no-hd-no-tl-roots) + (partition (λ (x) (= tl (read-root x))) no-hd-roots)) + (parameterize ([active-roots no-hd-no-tl-roots]) + (collector:cons (make-root 'hd + (λ () hd) + (λ (v) + (set! hd v) + (for ([r (in-list hd-roots)]) + (set-root! r v)))) + (make-root 'tl + (λ () tl) + (λ (v) + (set! tl v) + (for ([r (in-list tl-roots)]) + (set-root! r v)))))))]) + cons)) + +(define (do-alloc-flat flat) + (parameterize ([active-roots (compute-current-roots)]) + (collector:alloc-flat flat))) + ; Real Macros (define-syntax-rule (mutator-define-values (id ...) e) (begin (define-values (id ...) @@ -205,16 +232,46 @@ closure))]) #,(if (syntax-parameter-value #'mutator-tail-call?) (syntax/loc stx - (#%app collector:closure closure (vector free-id ...))) + (#%app do-collector:closure closure + (list (λ () free-id) ...) + (list (λ (v) (set! free-id v)) ...))) (syntax/loc stx (with-continuation-mark gc-roots-key (list (make-env-root env-id) ...) - (#%app collector:closure closure (vector free-id ...)))))))))] + (#%app do-collector:closure closure + (list (λ () free-id) ...) + (list (λ (v) (set! free-id v)) ...)))))))))] [(_ (id ...) body ...) (syntax/loc stx (mutator-lambda (id ...) (mutator-begin body ...)))])) +(define (do-collector:closure closure getters setters) + (define-values (remaining-roots closure-roots) + (let loop ([getters getters] + [setters setters] + [remaining-roots (compute-current-roots)] + [closure-roots '()]) + (cond + [(null? getters) (values remaining-roots closure-roots)] + [else + (define this-loc ((car getters))) + (define this-setter (car setters)) + (define-values (this-other-roots leftovers) + (filter (λ (x) (= (read-root x) this-loc)) remaining-roots)) + (loop (cdr getters) (cdr setters) + leftovers + (cons (make-root 'closure-root + (λ () this-loc) + (λ (v) + (set! this-loc v) + (this-setter v) + (for ([root (in-list this-other-roots)]) + (set-root! v)))) + closure-roots))]))) + (parameterize ([active-roots remaining-roots]) + (collector:closure closure closure-roots))) + (define-syntax (mutator-app stx) (syntax-case stx () [(_ e ...) @@ -247,7 +304,7 @@ stx))) (with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)] [app-exp (if prim-app? - (syntax/loc stx (collector:alloc-flat (fe (collector:deref ae) ...))) + (syntax/loc stx (do-alloc-flat (fe (collector:deref ae) ...))) (syntax/loc stx ((deref-proc fe) ae ...)))]) (if (syntax-parameter-value #'mutator-tail-call?) ; If this call is in tail position, we will not need access @@ -261,13 +318,13 @@ (define-syntax mutator-quote (syntax-rules () [(_ (a . d)) - (mutator-app collector:cons (mutator-quote a) (mutator-quote d))] + (mutator-app mutator-cons (mutator-quote a) (mutator-quote d))] [(_ s) (mutator-datum . s)])) (define-syntax (mutator-datum stx) (syntax-case stx () [(_ . e) - (quasisyntax/loc stx (mutator-anf-app collector:alloc-flat (#%datum . e)))])) + (quasisyntax/loc stx (mutator-anf-app do-alloc-flat (#%datum . e)))])) (define-syntax (mutator-top-interaction stx) (syntax-case stx (require provide mutator-define mutator-define-values test/value=? import-primitives) @@ -404,7 +461,7 @@ (let ([result (apply renamed-id (map collector:deref args))]) (cond [(void? result) (void)] - [(heap-value? result) (collector:alloc-flat result)] + [(heap-value? result) (do-alloc-flat result)] [else (error 'id (string-append "imported primitive must return , " "received ~a" result))])))) @@ -447,7 +504,7 @@ (define (member? v l) (and (member v l) #t)) (define (mutator-member? v l) - (collector:alloc-flat + (do-alloc-flat (member? (collector:deref v) (gc->scheme l)))) @@ -480,17 +537,17 @@ (define (mutator-empty? loc) (cond [(collector:flat? loc) - (collector:alloc-flat (empty? (collector:deref loc)))] + (do-alloc-flat (empty? (collector:deref loc)))] [else - (collector:alloc-flat false)])) + (do-alloc-flat false)])) (provide (rename-out [mutator-cons? cons?])) (define (mutator-cons? loc) - (collector:alloc-flat (collector:cons? loc))) + (do-alloc-flat (collector:cons? loc))) (provide (rename-out [mutator-eq? eq?])) (define (mutator-eq? l1 l2) - (collector:alloc-flat (= l1 l2))) + (do-alloc-flat (= l1 l2))) (provide (rename-out [mutator-printf printf])) (define-syntax (mutator-printf stx) diff --git a/collects/plai/gc2/private/collector-exports.rkt b/collects/plai/gc2/private/collector-exports.rkt index 539efa4f29..e6e96ddd1c 100644 --- a/collects/plai/gc2/private/collector-exports.rkt +++ b/collects/plai/gc2/private/collector-exports.rkt @@ -1,5 +1,6 @@ -#lang scheme -(require (for-syntax racket/syntax)) +#lang racket/base +(require (for-syntax racket/syntax + racket/base)) (provide (all-defined-out)) (define-syntax (define-collector-export stx) @@ -7,8 +8,9 @@ [(_ i) (with-syntax ([collector:i (format-id #'i "collector:~a" #'i)] - [set-collector:i! (format-id #'i "set-collector:~a!" #'i)]) - #'(begin (define collector:i false) + [set-collector:i! (format-id #'i "set-collector:~a!" #'i)] + [uninit-collector:i (format-id #'i "uninit-collector:~a" #'i)]) + #'(begin (define collector:i 'uninit-collector:i) (define (set-collector:i! proc) (set! collector:i proc))))])) diff --git a/collects/plai/gc2/private/gc-core.rkt b/collects/plai/gc2/private/gc-core.rkt index 1f748aa53a..a4c5648050 100644 --- a/collects/plai/gc2/private/gc-core.rkt +++ b/collects/plai/gc2/private/gc-core.rkt @@ -145,47 +145,41 @@ (set! global-roots (cons root global-roots))) (provide get-root-set) -(define-syntax (get-root-set stx) - (syntax-case stx () - [(_ root-id ...) - (andmap identifier? (syntax->list #'(root-id ...))) - #`(get-root-set/proc (list (λ () root-id) ...) - (list (λ (x) (set! root-id x)) ...) - '(root-id ...))] - [(_ e ...) - (let ([err (ormap (λ (x) (and (not (identifier? x)) x)) (syntax->list #'(e ...)))]) - (raise-syntax-error false - "expected an identifier to treat as a root" - stx - err))] - [_ (raise-syntax-error false - "missing open parenthesis" - stx)])) +(define (get-root-set) (append (active-roots) (user-specified-roots))) -(define (get-root-set/proc root-getters root-setters root-ids) - (append - (for/list ([root-getter (in-list root-getters)] - [root-setter (in-list root-setters)] - [root-id (in-list root-ids)]) - (if (location? (root-getter)) - (make-root root-id root-getter root-setter) - (error 'get-root-set "expected a location, given ~e" (root-getter)))) - (get-global-roots) - (stack-roots) - (user-specified-roots))) +(provide compute-current-roots) +(define (compute-current-roots) (append (get-global-roots) (stack-roots))) + +(provide active-roots) +(define active-roots (make-parameter '())) (provide with-roots) -(define-syntax-rule - (with-roots e1 e2 e3 ...) - (with-roots/proc e1 (λ () e2 e3 ...))) +(define-syntax (with-roots stx) + (syntax-case stx () + [(_ (x ...) e2 e3 ...) + (begin + (for ([x (in-list (syntax->list #'(x ...)))]) + (unless (identifier? #'x) + (raise-syntax-error 'with-roots "expected an identifier" stx x))) + #'(with-roots/proc + (list (λ () x) ...) + (list (λ (v) (set! x v)) ...) + (λ () e2 e3 ...)))])) -(define (with-roots/proc roots thunk) +(define (with-roots/proc getters setters thunk) (define c (listof location?)) - (unless (c roots) - (raise-argument-error 'with-roots - (format "~s" (contract-name c)) - roots)) - (parameterize ([user-specified-roots (append roots (user-specified-roots))]) + (for ([getter (in-list getters)]) + (define rt (getter)) + (unless (location? rt) + (raise-argument-error 'with-roots + 'location? + rt))) + (parameterize ([user-specified-roots + (append + (map (λ (x y) (make-root 'user-specified x y)) + getters + setters) + (user-specified-roots))]) (thunk))) (define user-specified-roots (make-parameter '())) diff --git a/collects/plai/scribblings/collector2.scrbl b/collects/plai/scribblings/collector2.scrbl index 6c6c3c7f2e..38330f6770 100644 --- a/collects/plai/scribblings/collector2.scrbl +++ b/collects/plai/scribblings/collector2.scrbl @@ -16,14 +16,13 @@ halt-on-errors print-only-errors test-inexact-epsilon plai-ignore-exn-strings plai-all-test-results) - (only-in plai/collector + (only-in plai/gc2/collector root? heap-size location? heap-value? heap-set! heap-ref with-heap - get-root-set read-root set-root! - procedure-roots) + get-root-set read-root set-root! make-root) plai/scribblings/fake-collector plai/scribblings/fake-mutator plai/scribblings/fake-web @@ -31,7 +30,7 @@ (only-in plai/web no-web-browser static-files-path) - (only-in plai/mutator + (only-in plai/gc2/mutator set-first! set-rest! import-primitives @@ -84,9 +83,10 @@ Determines if @racket[v] is a root. Returns the value at @racket[_loc]. } -@defform/subs[(get-root-set id ...)()]{ - Returns the current roots as a list. Local roots are created for the - identifiers @racket[_id] as well. +@defform[(get-root-set)]{ + Returns the current @racket[root?]s as a list. This returns + valid roots only when invoked via the mutator language. Otherwise + it returns only what has been set up with @racket[with-roots]. } @defproc[(read-root (root root?)) location?]{ @@ -94,13 +94,21 @@ Determines if @racket[v] is a root. } @defproc[(set-root! (root root?) (loc location?)) void?]{ - Updates the root to reference the given location. + Updates @racket[root] to refer to @racket[loc]. } -@defproc[(procedure-roots (proc procedure?)) (listof root?)]{ - Given a closure stored on the heap, returns a list of the roots reachable - from the closure's environment. If @racket[_proc] is not reachable, the - empty list is returned. +@defproc[(make-root [name symbol?] [get (-> location?)] [set (-> location? void?)]) + root?]{ + Creates a new root. When @racket[read-root] is called, it invokes + @racket[get] and when @racket[set-root!] is called, it invokes + @racket[set]. + + For example, this creates a root that uses the local variable + @racket[x] to hold its location: + @racketblock[(let ([x 1]) + (make-root 'x + (λ () x) + (λ (new-x) (set! x new-x))))] } @defform[(with-heap heap-expr body-expr ...) @@ -115,28 +123,35 @@ Determines if @racket[v] is a root. 2) ]} -@defform[(with-roots roots-expr expr1 expr2 ...) +@defform[(with-roots (root-var ...) expr1 expr2 ...) #:contracts ([roots-expr (listof location?)])]{ Evaluates each of @racket[expr1] and the @racket[expr2]s in - in a context with the result of @racket[roots-expr] - as additional roots. + in a context with additional roots, one for each of + the @racket[root-var]s. The @racket[get-root-set] function + returns these additional roots. Calling @racket[read-root] on + one of the newly created roots returns the value of the + corresponding @racket[root-var] and calling @racket[set-root!] + mutates the corresponding variable. - This function is intended to be used in test suites + This form is intended to be used in test suites for collectors. Since your test suites are not running in the @racketmod[plai/gc2/mutator] language, @racket[get-root-set] returns a list consisting only of the roots it created, not all of the other roots it normally would return. - Use this function to note specific locations as roots + Use @racket[with-roots] to note specific locations as roots and set up better tests for your GC. @racketblock[ (test (with-heap (make-vector 4) (define f1 (gc:alloc-flat 1)) - (define c1 (gc:cons f1 f1)) - (with-roots (list c1) + (define r1 (make-root 'f1 + (λ () f1) + (λ (v) (set! f1 v)))) + (define c1 (gc:cons r1 r1)) + (with-roots (c1) (gc:deref (gc:first - (gc:cons f1 f1))))) + (gc:cons r1 r1))))) 1)] } @@ -178,9 +193,9 @@ language exposes the environment via the @racket[procedure-roots] function. } -@defproc[(gc:cons (first location?) (rest location?)) location?]{ +@defproc[(gc:cons (first root?) (rest root?)) location?]{ -Given the location of the @racket[_first] and @racket[_rest] values, this +Given two roots, one for the @racket[first] and @racket[rest] values, this procedure must allocate a cons cell on the heap. If there is insufficient space to allocate the cons cell, it should signal an error. @@ -202,37 +217,37 @@ field. Otherwise, it should signal an error. @defproc[(gc:set-first! (cons-cell location?) (first-value location?)) void?]{ -If @racket[_cons-cell] refers to a cons cell, set the head of the cons cell to -@racket[_first-value]. Otherwise, signal an error. +If @racket[cons-cell] refers to a cons cell, set the head of the cons cell to +@racket[first-value]. Otherwise, signal an error. } @defproc[(gc:set-rest! (cons-cell location?) (rest-value location?)) void?]{ -If @racket[_cons-cell] refers to a cons cell, set the tail of the cons cell to -@racket[_rest-value]. Otherwise, signal an error. +If @racket[cons-cell] refers to a cons cell, set the tail of the cons cell to +@racket[rest-value]. Otherwise, signal an error. } @defproc[(gc:cons? (loc location?)) boolean?]{ -Returns @racket[true] if @racket[_loc] refers to a cons cell. This function +Returns @racket[#true] if @racket[loc] refers to a cons cell. This function should never signal an error. } @defproc[(gc:flat? (loc location?)) boolean?]{ -Returns @racket[true] if @racket[_loc] refers to a flat value. This function +Returns @racket[#true] if @racket[loc] refers to a flat value. This function should never signal an error. } -@defproc[(gc:closure [code-ptr heap-value?] [free-vars (vectorof location?)]) +@defproc[(gc:closure [code-ptr heap-value?] [free-vars (listof root?)]) location?]{ - Allocates a closure with 'code-ptr' and the free variables - in the vector 'free-vars'. + Allocates a closure with @racket[code-ptr] and the free variables + in the list @racket[free-vars]. } @defproc[(gc:closure-code-ptr [loc location?]) heap-value?]{ Given a location returned from an earlier allocation diff --git a/collects/tests/plai/gc2/good-collectors/good-collector.rkt b/collects/tests/plai/gc2/good-collectors/good-collector.rkt index 72d814c5f1..87497439e0 100644 --- a/collects/tests/plai/gc2/good-collectors/good-collector.rkt +++ b/collects/tests/plai/gc2/good-collectors/good-collector.rkt @@ -169,21 +169,21 @@ A collector for use in testing the random mutator generator. ptr)) (define (gc:cons hd tl) - (let ([ptr (alloc 3 (λ () (get-root-set hd tl)))]) - (heap-set! ptr 'pair) - (heap-set! (+ ptr 1) hd) - (heap-set! (+ ptr 2) tl) - ptr)) + (define ptr (alloc 3 (λ () (list* hd tl (get-root-set))))) + (heap-set! ptr 'pair) + (heap-set! (+ ptr 1) (read-root hd)) + (heap-set! (+ ptr 2) (read-root tl)) + ptr) (define (gc:closure code env) - (define len (vector-length env)) - (define ptr (alloc (+ 3 len) (λ () (append (get-root-set) (vector->roots env))))) + (define len (length env)) + (define ptr (alloc (+ 3 len) (λ () (append (get-root-set) env)))) (heap-set! ptr 'closure) (heap-set! (+ ptr 1) code) (heap-set! (+ ptr 2) len) - (for ([v (in-vector env)] + (for ([r (in-list env)] [i (in-naturals)]) - (heap-set! (+ ptr 3 i) v)) + (heap-set! (+ ptr 3 i) (read-root r))) ptr) (define (alloc n get-roots) @@ -339,12 +339,14 @@ A collector for use in testing the random mutator generator. (vector 'free 'free 'free 'free 'pair 4 4)) (test (with-heap (make-vector 50) - (with-roots (list 1 2 3) - (get-root-set))) + (let ([x 1][y 2][z 3]) + (with-roots (x y z) + (map read-root (get-root-set))))) (list 1 2 3)) (test (with-heap (make-vector 50) - (with-roots (list 1 2 3) - (with-roots (list 4 5 6) - (sort (get-root-set) <)))) - (list 1 2 3 4 5 6)) \ No newline at end of file + (let ([x 1][y 2][z 3][a 4][b 5][c 6]) + (with-roots (x y z) + (with-roots (a b c) + (sort (map read-root (get-root-set)) <))))) + (list 1 2 3 4 5 6)) diff --git a/collects/tests/plai/gc2/good-collectors/trivial-collector.rkt b/collects/tests/plai/gc2/good-collectors/trivial-collector.rkt index dc0a2b6779..1d6b5e5723 100644 --- a/collects/tests/plai/gc2/good-collectors/trivial-collector.rkt +++ b/collects/tests/plai/gc2/good-collectors/trivial-collector.rkt @@ -5,15 +5,15 @@ ; calling heap-offset before init-allocator is called gives 'undefined (set! heap-ptr 0)) -(define (gc:closure code vs) - (define len (vector-length vs)) +(define (gc:closure code roots) + (define len (length roots)) (when (> (+ heap-ptr len) (heap-size)) (error "out of memory")) (heap-set! heap-ptr 'closure) (heap-set! (+ 1 heap-ptr) code) - (for ([v (in-vector vs)] + (for ([r (in-list roots)] [i (in-naturals 1)]) - (heap-set! (+ 1 i heap-ptr) v)) + (heap-set! (+ 1 i heap-ptr) (read-root r))) (set! heap-ptr (+ len 2 heap-ptr)) ;; return the location of this flat data (- heap-ptr len 2)) @@ -40,8 +40,8 @@ (when (> (+ heap-ptr 3) (heap-size)) (error "out of memory")) (heap-set! heap-ptr 'cons) - (heap-set! (+ 1 heap-ptr) f) - (heap-set! (+ 2 heap-ptr) r) + (heap-set! (+ 1 heap-ptr) (read-root f)) + (heap-set! (+ 2 heap-ptr) (read-root r)) (set! heap-ptr (+ 3 heap-ptr)) (- heap-ptr 3))) @@ -74,18 +74,13 @@ (module+ test (require rackunit) - (check-equal? (with-heap (vector 2 3) - (let ([x 0]) - (set-root! (car (get-root-set x)) 1) - x)) - 1) (check-equal? (let ([h (make-vector 7)]) (with-heap h (init-allocator) (define one (gc:alloc-flat 1)) - (define clos (gc:closure 'something (vector one))) + (define clos (gc:closure 'something (list (make-root 'dummy (λ () one) void)))) (gc:alloc-flat 2)) h) (vector 'prim 1 'closure 'something 0 'prim 2))) diff --git a/collects/tests/plai/gc2/roots-test.rkt b/collects/tests/plai/gc2/roots-test.rkt index 11af9c8f25..8046c783f5 100644 --- a/collects/tests/plai/gc2/roots-test.rkt +++ b/collects/tests/plai/gc2/roots-test.rkt @@ -11,7 +11,7 @@ that prints out all of the flat values in the root set at the point when a cons happens. Then it sets up various little expressions (in the calls to 'run-one') -that check the root set contents. +that check the root set contents and the arguments to cons. The roots are printed only if they are flat values and the values themselves are printed, sorted with duplicates removed. (Also the code @@ -64,14 +64,16 @@ that the test cases have to be set up somewhat carefully. (begin (when (> (+ heap-ptr 3) (heap-size)) (error "out of memory")) + (define (get-prim x) (heap-ref (+ (read-root x) 1))) (define prim-roots (for/list ([x (in-list (get-root-set))] #:when (eq? 'prim (heap-ref (read-root x)))) - (heap-ref (+ (read-root x) 1)))) - (printf "~s\n" (cons 'roots (remove-duplicates (sort prim-roots <)))) + (get-prim x))) + (printf "~s\n" (append (cons 'roots (remove-duplicates (sort prim-roots <))) + (list 'hd (get-prim f) 'tl (get-prim r)))) (heap-set! heap-ptr 'cons) - (heap-set! (+ 1 heap-ptr) f) - (heap-set! (+ 2 heap-ptr) r) + (heap-set! (+ 1 heap-ptr) (read-root f)) + (heap-set! (+ 2 heap-ptr) (read-root r)) (set! heap-ptr (+ 3 heap-ptr)) (- heap-ptr 3))) @@ -119,21 +121,21 @@ that the test cases have to be set up somewhat carefully. @run-one['non-tail-cons]{#lang plai/gc2/mutator (allocator-setup 'gc 200) (first (cons 1 2))} - '((roots 1 2))) + '((roots hd 1 tl 2))) (check-equal? @run-one['tail-cons]{#lang plai/gc2/mutator (allocator-setup 'gc 200) (define (f x) (cons 1 2)) (f 3)} - '((roots 3))) + '((roots 3 hd 1 tl 2))) (check-equal? @run-one['tail-cons-with-unused-var]{#lang plai/gc2/mutator (allocator-setup 'gc 200) (define (f x) (let ([y 2]) (cons 3 4))) (f 1)} - '((roots 1))) + '((roots 1 hd 3 tl 4))) (check-equal? @run-one['cons-with-used-var]{#lang plai/gc2/mutator @@ -142,7 +144,7 @@ that the test cases have to be set up somewhat carefully. (let ([z (cons 3 4)]) y))) (f 1)} - '((roots 1 2 3 4))) + '((roots 1 2 hd 3 tl 4))) (check-equal? @@ -152,7 +154,7 @@ that the test cases have to be set up somewhat carefully. (let ([z (cons 3 4)]) x))) (f 1)} - '((roots 1 3 4))) + '((roots 1 hd 3 tl 4))) (check-equal? @@ -162,7 +164,7 @@ that the test cases have to be set up somewhat carefully. [(z) (cons 3 4)]) x)) (f 1)} - '((roots 1 3 4))) + '((roots 1 hd 3 tl 4))) (check-equal? @run-one['let-values2]{#lang plai/gc2/mutator @@ -171,7 +173,7 @@ that the test cases have to be set up somewhat carefully. [(z) (cons 3 4)]) y)) (f 1)} - '((roots 1 2 3 4))) + '((roots 1 2 hd 3 tl 4))) (check-equal? @run-one['fn-args]{#lang plai/gc2/mutator @@ -179,7 +181,7 @@ that the test cases have to be set up somewhat carefully. (define (f x) (let ([z (cons 1 2)]) x)) (define (g y) (f 3)) (g 4)} - '((roots 1 2 3 4))) + '((roots 3 4 hd 1 tl 2))) (check-equal? @run-one['fn-args2]{#lang plai/gc2/mutator @@ -187,7 +189,7 @@ that the test cases have to be set up somewhat carefully. (define (f x) (let ([z (cons 1 2)]) z)) (define (g y) (f 3)) (g 4)} - '((roots 1 2 4))) + '((roots 4 hd 1 tl 2))) (check-equal? @run-one['fn-args3]{#lang plai/gc2/mutator @@ -195,4 +197,4 @@ that the test cases have to be set up somewhat carefully. (define (f x) (cons 1 2)) (define (g y) (f 3)) (g 4)} - '((roots 4))) + '((roots 4 hd 1 tl 2))) diff --git a/collects/tests/plai/gc2/run-test.rkt b/collects/tests/plai/gc2/run-test.rkt index 11598f3029..de3e2fda6d 100644 --- a/collects/tests/plai/gc2/run-test.rkt +++ b/collects/tests/plai/gc2/run-test.rkt @@ -12,7 +12,7 @@ (directory-list pth))))) (define (test-mutator m) - (printf "Running ~a\n" m) + (printf "Running ~a\n" (simplify-path m)) (parameterize ([current-namespace (make-base-empty-namespace)]) (dynamic-require m #f)))