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 # (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 @@ 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 + (( table) + (let ((key (cons (module-name (current-module)) sym))) + (assoc-ref table key))) + (( 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 (( 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)))) (( 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))))))) + (cond + ((assq-ref table sym) + => (lambda (var) + (or (eq? e env) + (force-heap-allocation! var)) + var)) + (else + (loop parent))))))) -(define (ghil-define toplevel sym) +(define (ghil-var-for-set! env sym) + (let loop ((e env)) + (record-case e + (( 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)))) + (( 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))) 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))