summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/scheme/translate.scm8
-rw-r--r--module/system/il/ghil.scm77
-rw-r--r--testsuite/Makefile.am1
-rw-r--r--testsuite/t-call-cc.scm16
4 files changed, 78 insertions, 24 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 799e67c23..87057d89e 100644
--- a/module/language/scheme/translate.scm
+++ b/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)
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 1398bd17f..92abfc343 100644
--- a/module/system/il/ghil.scm
+++ b/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
-;; the innermost environment, make sure the variable is marked as being
-;; "external" so that it goes on the heap.
+;; These functions first search the lexical environments. If the
+;; variable is not in the innermost environment, make sure the variable
+;; 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)
+ (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)
+ (or (eq? e env)
+ (force-heap-allocation! var))
+ var))
+ (else
+ (loop parent)))))))
+
+(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)
- (and (or (null? define?)
- (car define?))
- (let ((var (make-ghil-var (car key) (cdr key) 'module)))
- (apush! key var (ghil-toplevel-env-table e))
- var)))))
+ (let ((var (make-ghil-var (car key) (cdr key) 'module)))
+ (apush! key var (ghil-toplevel-env-table e))
+ var))))
((<ghil-env> parent table variables)
- (let ((found (assq-ref table sym)))
- (if found
- (begin
- (if (not (eq? e env))
- (set! (ghil-var-kind found) 'external))
- found)
- (loop parent)))))))
-
-(define (ghil-define toplevel sym)
+ (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)))
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index 59ef56587..6ff48b5de 100644
--- a/testsuite/Makefile.am
+++ b/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 \
diff --git a/testsuite/t-call-cc.scm b/testsuite/t-call-cc.scm
new file mode 100644
index 000000000..05e4de98c
--- /dev/null
+++ b/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))