diff options
author | Marius Vollmer <mvo@zagadka.de> | 2002-09-04 21:33:33 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2002-09-04 21:33:33 +0000 |
commit | db3f1c7e61f8ea3d29ca6179f8ae4b2a3f1872a5 (patch) | |
tree | b36b7bb6478e328e4cec2408f1ff5b6fc1b2ee3c | |
parent | a27e3d1463770728e48d0a47339f779a11bf4c02 (diff) | |
download | guile-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.scm | 22 |
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) |