summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2002-09-04 21:33:33 +0000
committerMarius Vollmer <mvo@zagadka.de>2002-09-04 21:33:33 +0000
commitdb3f1c7e61f8ea3d29ca6179f8ae4b2a3f1872a5 (patch)
treeb36b7bb6478e328e4cec2408f1ff5b6fc1b2ee3c
parenta27e3d1463770728e48d0a47339f779a11bf4c02 (diff)
downloadguile-db3f1c7e61f8ea3d29ca6179f8ae4b2a3f1872a5.tar.gz
(expansion-eval-closure, env->eval-closure): New.
(sc-macro): Set the expansion-eval-closure expanding the form. (putprop, getprop): Use the expansion-eval-closure to find variables instead of the current module.
-rw-r--r--ice-9/syncase.scm22
1 files changed, 15 insertions, 7 deletions
diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm
index 8d61bd120..fff3ca199 100644
--- a/ice-9/syncase.scm
+++ b/ice-9/syncase.scm
@@ -57,10 +57,20 @@
+(define expansion-eval-closure (make-fluid))
+
+(define (env->eval-closure env)
+ (or (and env
+ (car (last-pair env)))
+ (module-eval-closure the-root-module)))
+
(define sc-macro
(procedure->memoizing-macro
(lambda (exp env)
- (sc-expand exp))))
+ (with-fluids ((expansion-eval-closure (env->eval-closure env)))
+ (sc-expand exp)))))
+
+(fluid-set! expansion-eval-closure (env->eval-closure #f))
;;; Exported variables
@@ -127,13 +137,12 @@
'())))
(define the-syncase-module (current-module))
+(define the-syncase-eval-closure (module-eval-closure the-syncase-module))
(define (putprop symbol key binding)
- (let* ((m (current-module))
- (v (or (module-variable m symbol)
- (module-make-local-var! m symbol))))
+ (let* ((v ((fluid-ref expansion-eval-closure) symbol #t)))
(if (symbol-property symbol 'primitive-syntax)
- (if (eq? (current-module) the-syncase-module)
+ (if (eq? (fluid-ref expansion-eval-closure) the-syncase-eval-closure)
(set-object-property! (module-variable the-root-module symbol)
key
binding))
@@ -141,8 +150,7 @@
(set-object-property! v key binding)))
(define (getprop symbol key)
- (let* ((m (current-module))
- (v (module-variable m symbol)))
+ (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
(and v (or (object-property v key)
(let ((root-v (module-local-variable the-root-module symbol)))
(and (equal? root-v v)