From 46eb91b5787c948a7c0c539fe5242a4929b2561c Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 8 Mar 2013 16:23:09 -0600
Subject: [PATCH] fix a bug in the way let-values decided which variables are
 roots

also, Rackety
---
 collects/plai/gc2/mutator.rkt                | 27 +++++------
 collects/plai/gc2/private/gc-transformer.rkt | 49 +++++++++++++-------
 2 files changed, 43 insertions(+), 33 deletions(-)

diff --git a/collects/plai/gc2/mutator.rkt b/collects/plai/gc2/mutator.rkt
index ec36a193d5..9c1ed299fe 100644
--- a/collects/plai/gc2/mutator.rkt
+++ b/collects/plai/gc2/mutator.rkt
@@ -141,41 +141,38 @@
            (raise-syntax-error 'set! "allowed only inside begin expressions and at the top-level" stx)))]))
 (define-syntax (mutator-let-values stx)
   (syntax-case stx ()
-    [(_ ([(id ...) expr]
-         ...)
-        body-expr)
+    [(_ ([(id ...) expr] ...) body-expr)
      (with-syntax ([((tmp ...) ...)
                     (map generate-temporaries (syntax->list #'((id ...) ...)))])
-       (let ([binding-list (syntax->list #'((tmp ...) ...))])
-         (with-syntax ([((previous-tmp ...) ...)
+       (let ([binding-list (syntax->list #'((id ...) ...))])
+         (with-syntax ([((previous-id ...) ...)
                         (build-list (length binding-list) 
                                     (λ (n) (append-map syntax->list (take binding-list n))))])
            (syntax/loc stx
              (let*-values ([(tmp ...) 
                             (syntax-parameterize ([mutator-env-roots 
                                                    (append
-                                                    (find-referenced-locals
-                                                     (list #'previous-tmp ...)
-                                                     #'expr)
+                                                    (switch-over
+                                                     (syntax->list #'(id ... ...))
+                                                     (syntax->list #'(tmp ... ...))
+                                                     (find-referenced-locals
+                                                      (list #'previous-id ...)
+                                                      #'body-expr))
                                                     (syntax-parameter-value #'mutator-env-roots))]
                                                   [mutator-tail-call? #f])
                                                  (no! expr))]
                            ...)
-               (let-values ([(id ...) (values tmp ...)]
-                            ...)
+               (let-values ([(id ...) (values tmp ...)] ...)
                  (syntax-parameterize ([mutator-env-roots 
                                         (append (find-referenced-locals
                                                  (list #'id ... ...)
                                                  #'body-expr)
                                                 (syntax-parameter-value #'mutator-env-roots))])
                                       body-expr)))))))]
-    [(_ ([(id ...) expr]
-         ...)
-        body-expr ...)
+    [(_ ([(id ...) expr] ...) body-expr ...)
      (syntax/loc stx
        (mutator-let-values
-        ([(id ...) expr]
-         ...)
+        ([(id ...) expr] ...)
         (mutator-begin body-expr ...)))]))
 (define-syntax (mutator-lambda stx)
   (syntax-case stx ()
diff --git a/collects/plai/gc2/private/gc-transformer.rkt b/collects/plai/gc2/private/gc-transformer.rkt
index 9d905f95b4..bf0714ef2a 100644
--- a/collects/plai/gc2/private/gc-transformer.rkt
+++ b/collects/plai/gc2/private/gc-transformer.rkt
@@ -1,20 +1,33 @@
-#lang scheme
+#lang racket/base
+(require racket/contract
+         racket/dict)
+(provide
+ (contract-out
+  [find-referenced-locals (-> (listof identifier?) syntax? (listof identifier?))]
+  [switch-over (-> (listof identifier?) (listof identifier?) (listof identifier?) (listof identifier?))]))
 
-(provide/contract (find-referenced-locals ((listof identifier?) syntax? . -> . (listof identifier?))))
 (define (find-referenced-locals env-ids stx)
-  (local ([define id-hash (make-custom-hash free-identifier=?
-                                            (λ (v) (equal-hash-code (syntax->datum v)))
-                                            (λ (v) (equal-secondary-hash-code (syntax->datum v))))]
-          [define (find stx)
-            (syntax-case stx ()
-              [(head . tail)
-               (begin
-                 (find #'head)
-                 (find #'tail))]
-              [id (identifier? stx)
-                  (begin
-                    (unless (dict-ref id-hash stx false)
-                    (dict-set! id-hash stx true)))]
-              [_ (void)])])
-    (find stx)
-    (filter (λ (env-id) (dict-ref id-hash env-id false)) env-ids)))
+  (define id-hash
+    (make-custom-hash free-identifier=?
+                      (λ (v) (equal-hash-code (syntax->datum v)))
+                      (λ (v) (equal-secondary-hash-code (syntax->datum v)))))
+  (let find ([stx stx])
+    (syntax-case stx ()
+      [(head . tail)
+       (begin
+         (find #'head)
+         (find #'tail))]
+      [id (identifier? stx)
+          (unless (dict-ref id-hash stx #false)
+            (dict-set! id-hash stx #true))]
+      [_ (void)]))
+  (filter (λ (env-id) (dict-ref id-hash env-id #false)) env-ids))
+
+(define (switch-over src-ids dest-ids to-switch)
+  (for/list ([id (in-list to-switch)])
+    (or (for/or ([src-id (in-list src-ids)]
+                 [dest-id (in-list dest-ids)])
+          (and (free-identifier=? src-id id)
+               dest-id))
+        (error 'switch-over "didn't find src-id for ~s" id))))
+