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

@@ -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:cons (root? root? . -> . location?)))
-          (provide/contract (gc:closure (closure-code? (vectorof location?) . -> . 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?)))          

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 <heap-value?>, "
                                               "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)

collects/plai/gc2/private/collector-exports.rkt

@@ -1,5 +1,6 @@
-#lang scheme
+#lang racket/base
-(require (for-syntax racket/syntax))
+(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)])
+       [set-collector:i! (format-id #'i "set-collector:~a!" #'i)]
-      #'(begin (define collector:i false)
+       [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))))]))
 

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)
+(define (get-root-set) (append (active-roots) (user-specified-roots)))
-  (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/proc root-getters root-setters root-ids)
+(provide compute-current-roots)
-  (append
+(define (compute-current-roots) (append (get-global-roots) (stack-roots)))
-   (for/list ([root-getter (in-list root-getters)]
+
-              [root-setter (in-list root-setters)]
+(provide active-roots)
-              [root-id (in-list root-ids)])
+(define active-roots (make-parameter '()))
-     (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 with-roots)
-(define-syntax-rule 
+(define-syntax (with-roots stx)
-  (with-roots e1 e2 e3 ...)
+  (syntax-case stx ()
-  (with-roots/proc e1 (λ () e2 e3 ...)))
+    [(_ (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)
+  (for ([getter (in-list getters)])
-    (raise-argument-error 'with-roots
+    (define rt (getter))
-                          (format "~s" (contract-name c))
+    (unless (location? rt)
-                          roots))
+      (raise-argument-error 'with-roots
-  (parameterize ([user-specified-roots (append roots (user-specified-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 '()))

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!
+                              get-root-set read-root set-root! make-root)
-                              procedure-roots)
                      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 ...)()]{
+@defform[(get-root-set)]{
-  Returns the current roots as a list.  Local roots are created for the
+  Returns the current @racket[root?]s as a list. This returns
-  identifiers @racket[_id] as well.
+  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?)]{
+@defproc[(make-root [name symbol?] [get (-> location?)] [set (-> location? void?)])
-  Given a closure stored on the heap, returns a list of the roots reachable
+         root?]{
-  from the closure's environment.  If @racket[_proc] is not reachable, the
+  Creates a new root. When @racket[read-root] is called, it invokes
-  empty list is returned.
+  @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]
+  in a context with additional roots, one for each of
-  as additional roots.
+  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))
+                     (define r1 (make-root 'f1 
-                     (with-roots (list c1)
+                                           (λ () 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
+If @racket[cons-cell] refers to a cons cell, set the head of the cons cell to
-@racket[_first-value].  Otherwise, signal an error.
+@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
+If @racket[cons-cell] refers to a cons cell, set the tail of the cons cell to
-@racket[_rest-value].  Otherwise, signal an error.
+@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
+  Allocates a closure with @racket[code-ptr] and the free variables
-  in the vector 'free-vars'.                                                                               
+  in the list @racket[free-vars].
 }
 @defproc[(gc:closure-code-ptr [loc location?]) heap-value?]{
  Given a location returned from an earlier allocation

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)))])
+  (define ptr (alloc 3 (λ () (list* hd tl (get-root-set)))))
-    (heap-set! ptr 'pair)
+  (heap-set! ptr 'pair)
-    (heap-set! (+ ptr 1) hd)
+  (heap-set! (+ ptr 1) (read-root hd))
-    (heap-set! (+ ptr 2) tl)
+  (heap-set! (+ ptr 2) (read-root tl))
-    ptr))
+  ptr)
 
 (define (gc:closure code env)
-  (define len (vector-length env))
+  (define len (length env))
-  (define ptr (alloc (+ 3 len) (λ () (append (get-root-set) (vector->roots 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)
+                 (let ([x 1][y 2][z 3])
-                             (get-root-set)))
+                   (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)
+                 (let ([x 1][y 2][z 3][a 4][b 5][c 6])
-                             (with-roots (list 4 5 6)
+                   (with-roots (x y z)
-                                         (sort (get-root-set) <))))
+                               (with-roots (a b c)
-      (list 1 2 3 4 5 6))
+                                           (sort (map read-root (get-root-set)) <)))))
+      (list 1 2 3 4 5 6))

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 (gc:closure code roots)
-  (define len (vector-length vs))
+  (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! (+ 1 heap-ptr) (read-root f))
-    (heap-set! (+ 2 heap-ptr) r)
+    (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)))

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))))
+              (get-prim x)))
-          (printf "~s\n" (cons 'roots (remove-duplicates (sort prim-roots <))))
+          (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! (+ 1 heap-ptr) (read-root f))
-          (heap-set! (+ 2 heap-ptr) r)
+          (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)))

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)))