allocate variables that are set! on the heap

* module/system/il/ghil.scm (ghil-lookup): So, it turns out this function
  needed to be split into three:
  (ghil-var-is-bound?, ghil-var-for-ref!, ghil-var-for-set!): The
  different facets of ghil-lookup. Amply commented in the source. The
  difference being that we now allocate variables that are set! on the
  heap, so that other continuations see their possibly-modified values.
  (force-heap-allocation!): New helper.

* testsuite/Makefile.am:
* testsuite/t-call-cc.scm: New test, that variables that are set! are
  allocated on the heap, so that subsequent modifications are still
  seen by the continuation. The test was distilled from test 7.3 in
  r5rs_pitfall.test.

module/language/scheme/translate.scm

@@ -102,7 +102,7 @@
                    (make-ghil-call e l (retrans head) tail)))))))
 
 	((symbol? x)
-         (make-ghil-ref e l (ghil-lookup e x)))
+         (make-ghil-ref e l (ghil-var-for-ref! e x)))
 
         ;; fixme: non-self-quoting objects like #<foo>
 	(else
@@ -146,7 +146,7 @@
     ;; (define NAME VAL)
     ((,name ,val) (guard (symbol? name)
                          (ghil-toplevel-env? (ghil-env-parent e)))
-     (make-ghil-define e l (ghil-define (ghil-env-parent e) name)
+     (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) name)
                        (maybe-name-value! (retrans val) name)))
     ;; (define (NAME FORMALS...) BODY...)
     (((,name . ,formals) . ,body) (guard (symbol? name))
@@ -156,7 +156,7 @@
    (set!
     ;; (set! NAME VAL)
     ((,name ,val) (guard (symbol? name))
-     (make-ghil-set e l (ghil-lookup e name) (retrans val)))
+     (make-ghil-set e l (ghil-var-for-set! e name) (retrans val)))
 
     ;; (set! (NAME ARGS...) VAL)
     (((,name . ,args) ,val) (guard (symbol? name))
@@ -311,7 +311,7 @@
      ((,proc ,arg1 . ,args)
       (let ((args (cons (retrans arg1) (map retrans args))))
         (cond ((and (symbol? proc)
-                    (not (ghil-lookup e proc #f))
+                    (not (ghil-var-is-bound? e proc))
                     (and=> (module-variable (current-module) proc)
                            (lambda (var)
                              (and (variable-bound? var)

module/system/il/ghil.scm

@@ -94,7 +94,8 @@
    <ghil-env> make-ghil-env ghil-env?
    ghil-env-parent ghil-env-table ghil-env-variables
 
-   ghil-env-add! ghil-lookup ghil-define
+   ghil-env-add!
+   ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
    call-with-ghil-environment call-with-ghil-bindings))
 
 
@@ -165,42 +166,78 @@
 (define (ghil-env-remove! env var)
   (apopq! (ghil-var-name var) (ghil-env-table env)))
 
+(define (force-heap-allocation! var)
+  (set! (ghil-var-kind var) 'external))
+  
+
 
 ;;;
 ;;; Public interface
 ;;;
 
-;; ghil-lookup: find out where a variable will be stored at runtime.
+;; The following four functions used to be one, in ghil-lookup. Now they
+;; are four, to reflect the different intents. A bit of duplication, but
+;; that's OK. The common current is to find out where a variable will be
+;; stored at runtime.
 ;;
-;; First searches the lexical environments. If the variable is not in
+;; These functions first search the lexical environments. If the
-;; the innermost environment, make sure the variable is marked as being
+;; variable is not in the innermost environment, make sure the variable
-;; "external" so that it goes on the heap.
+;; is marked as being "external" so that it goes on the heap. If the
+;; variable is being modified (via a set!), also make sure it's on the
+;; heap, so that other continuations see the changes to the var.
 ;;
 ;; If the variable is not found lexically, it is a toplevel variable,
 ;; which will be looked up at runtime with respect to the module that
 ;; was current when the lambda was bound, at runtime. The variable will
 ;; be resolved when it is first used.
-(define (ghil-lookup env sym . define?)
+(define (ghil-var-is-bound? env sym)
+  (let loop ((e env))
+    (record-case e
+      ((<ghil-toplevel-env> table)
+       (let ((key (cons (module-name (current-module)) sym)))
+         (assoc-ref table key)))
+      ((<ghil-env> parent table variables)
+       (and (not (assq-ref table sym))
+            (loop parent))))))
+
+(define (ghil-var-for-ref! env sym)
   (let loop ((e env))
     (record-case e
       ((<ghil-toplevel-env> table)
        (let ((key (cons (module-name (current-module)) sym)))
          (or (assoc-ref table key)
-             (and (or (null? define?)
+             (let ((var (make-ghil-var (car key) (cdr key) 'module)))
-                      (car define?))
+               (apush! key var (ghil-toplevel-env-table e))
-                  (let ((var (make-ghil-var (car key) (cdr key) 'module)))
+               var))))
-                    (apush! key var (ghil-toplevel-env-table e))
-                    var)))))
       ((<ghil-env> parent table variables)
-       (let ((found (assq-ref table sym)))
+       (cond
-         (if found
+        ((assq-ref table sym)
-             (begin
+         => (lambda (var)
-               (if (not (eq? e env))
+              (or (eq? e env)
-                   (set! (ghil-var-kind found) 'external))
+                  (force-heap-allocation! var))
-               found)
+              var))
-             (loop parent)))))))
+        (else
+         (loop parent)))))))
 
-(define (ghil-define toplevel sym)
+(define (ghil-var-for-set! env sym)
+  (let loop ((e env))
+    (record-case e
+      ((<ghil-toplevel-env> table)
+       (let ((key (cons (module-name (current-module)) sym)))
+         (or (assoc-ref table key)
+             (let ((var (make-ghil-var (car key) (cdr key) 'module)))
+               (apush! key var (ghil-toplevel-env-table e))
+               var))))
+      ((<ghil-env> parent table variables)
+       (cond
+        ((assq-ref table sym)
+         => (lambda (var)
+              (force-heap-allocation! var)
+              var))
+        (else
+         (loop parent)))))))
+
+(define (ghil-var-define! toplevel sym)
   (let ((key (cons (module-name (current-module)) sym)))
     (or (assoc-ref (ghil-toplevel-env-table toplevel) key)
         (let ((var (make-ghil-var (car key) (cdr key) 'module)))

testsuite/Makefile.am

@@ -7,6 +7,7 @@ vm_test_files =					\
       t-basic-contructs.scm			\
       t-global-bindings.scm			\
       t-catch.scm				\
+      t-call-cc.scm				\
       t-closure.scm				\
       t-closure2.scm				\
       t-closure3.scm				\

testsuite/t-call-cc.scm

@@ -0,0 +1,16 @@
+(let ((set-counter2 #f))
+  (define (get-counter2)
+    (call/cc
+     (lambda (k)
+       (set! set-counter2 k)
+       1)))
+  (define (loop counter1)
+    (let ((counter2 (get-counter2)))
+      (set! counter1 (1+ counter1))
+      (cond ((not (= counter1 counter2))
+             (error "bad call/cc behaviour" counter1 counter2))
+            ((> counter1 10)
+             #t)
+            (else
+             (set-counter2 (1+ counter2))))))
+  (loop 0))