add with-roots to plai's gc languages

collects/plai/gc2/private/gc-core.rkt

@@ -144,18 +144,8 @@
   (syntax-case stx ()
     [(_ root-id ...)
      (andmap identifier? (syntax->list #'(root-id ...)))
-     #`(begin
+     #`(get-root-set/proc (list root-id ...)
-         (append
+                          '(root-id ...))]
-          (list (if (location? root-id)
-                    (make-root 'root-id 
-                               (λ ()
-                                  root-id) 
-                               (λ (loc) 
-                                  (set! root-id loc)))
-                    (error 'get-root-set "expected a location, given ~e" root-id))
-                ...)
-          (get-global-roots)
-          (stack-roots)))]
     [(_ e ...)
      (let ([err (ormap (λ (x) (and (not (identifier? x)) x)) (syntax->list #'(e ...)))])
        (raise-syntax-error false
@@ -166,6 +156,37 @@
                            "missing open parenthesis"
                            stx)]))
 
+(define (get-root-set/proc root-locs root-ids)
+  (append
+   (for/list ([root-loc (in-list root-locs)]
+              [root-id (in-list root-ids)])
+     (if (location? root-loc)
+         (make-root root-id
+                    (λ ()
+                      root-loc) 
+                    (λ (loc) 
+                      (set! root-loc loc)))
+         (error 'get-root-set "expected a location, given ~e" root-loc)))
+   (get-global-roots)
+   (stack-roots)
+   (user-specified-roots)))
+
+(provide with-roots)
+(define-syntax-rule 
+  (with-roots e1 e2 e3 ...)
+  (with-roots/proc e1 (λ () e2 e3 ...)))
+
+(define (with-roots/proc roots 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))])
+    (thunk)))
+
+(define user-specified-roots (make-parameter '()))
+
 (provide/contract
  [vector->roots (-> (vectorof location?) (listof root?))])
 (define (vector->roots v)

collects/plai/private/gc-core.rkt

@@ -135,14 +135,7 @@
   (syntax-case stx ()
     [(_ root-id ...)
      (andmap identifier? (syntax->list #'(root-id ...)))
-     #`(begin
+     #`(get-root-set/proc (list root-id ...) '(root-id ...))]
-         (append
-          (list (make-root 'root-id (λ () root-id) 
-                           (λ (loc) 
-                             (set! root-id loc)))
-                ...)
-          (get-global-roots)
-          (stack-roots)))]
     [(_ e ...)
      (let ([err (ormap (λ (x) (and (not (identifier? x)) x)) (syntax->list #'(e ...)))])
        (raise-syntax-error false
@@ -153,6 +146,35 @@
                            "missing open parenthesis"
                            stx)]))
 
+(define (get-root-set/proc root-locs root-ids)
+  (append
+   (for/list ([root-loc (in-list root-locs)]
+              [root-id (in-list root-ids)])
+     (if (location? root-loc)
+         (make-root root-id
+                    (λ () root-loc) 
+                    (λ (loc) (set! root-loc loc)))
+         (error 'get-root-set "expected a location, given ~e" root-loc)))
+   (get-global-roots)
+   (stack-roots)
+   (user-specified-roots)))
+
+(provide with-roots)
+(define-syntax-rule 
+  (with-roots e1 e2 e3 ...)
+  (with-roots/proc e1 (λ () e2 e3 ...)))
+
+(define (with-roots/proc roots 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))])
+    (thunk)))
+
+(define user-specified-roots (make-parameter '()))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Environments of closures
 

collects/plai/scribblings/plai.scrbl

@@ -310,9 +310,10 @@ Determines if @racket[v] is a root.
   empty list is returned.
 }
 
-@defform[(with-heap heap expr ...)
+@defform[(with-heap heap-expr body-expr ...)
-         #:contracts ([heap (vectorof heap-value?)])]{
+         #:contracts ([heap-expr (vectorof heap-value?)])]{
- Evaluates @racket[(begin expr ...)] in the context of @racket[heap]. Useful in
+ Evaluates each of the @racket[body-expr]s in a context where
+ the value of @racket[heap-expr] is used as the heap. Useful in
  tests:
  @racketblock[
   (test (with-heap (make-vector 20) 
@@ -321,6 +322,32 @@ Determines if @racket[v] is a root.
         2)
   ]}
                                                      
+@defform[(with-roots roots-expr 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.
+  
+  This function is intended to be used in test suites
+  for collectors. Since your test suites are not running
+  in the @racketmod[plai/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
+  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)
+                                 (gc:deref
+                                  (gc:first
+                                   (gc:cons f1 f1)))))
+          1)]
+  
+}
+
 @subsection{Garbage Collector Exports}
 
 @declare-exporting[#:use-sources (plai/scribblings/fake-collector)]

collects/tests/plai/gc/good-collectors/good-collector.rkt

@@ -272,3 +272,13 @@ A collector for use in testing the random mutator generator.
                                            (remove 4 (get-all-records 0))))
         v)
       (vector 'free 'free 'free 'free 'pair 4 4))
+
+(test (with-heap (make-vector 50)
+                 (with-roots (list 1 2 3)
+                             (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))

collects/tests/plai/gc2/good-collectors/good-collector.rkt

@@ -338,3 +338,13 @@ A collector for use in testing the random mutator generator.
         v)
       (vector 'free 'free 'free 'free 'pair 4 4))
 
+(test (with-heap (make-vector 50)
+                 (with-roots (list 1 2 3)
+                             (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))