mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-04 03:00:20 +02:00
(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.
This commit is contained in:
parent
a27e3d1463
commit
db3f1c7e61
1 changed files with 15 additions and 7 deletions
|
@ -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
|
(define sc-macro
|
||||||
(procedure->memoizing-macro
|
(procedure->memoizing-macro
|
||||||
(lambda (exp env)
|
(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
|
;;; Exported variables
|
||||||
|
|
||||||
|
@ -127,13 +137,12 @@
|
||||||
'())))
|
'())))
|
||||||
|
|
||||||
(define the-syncase-module (current-module))
|
(define the-syncase-module (current-module))
|
||||||
|
(define the-syncase-eval-closure (module-eval-closure the-syncase-module))
|
||||||
|
|
||||||
(define (putprop symbol key binding)
|
(define (putprop symbol key binding)
|
||||||
(let* ((m (current-module))
|
(let* ((v ((fluid-ref expansion-eval-closure) symbol #t)))
|
||||||
(v (or (module-variable m symbol)
|
|
||||||
(module-make-local-var! m symbol))))
|
|
||||||
(if (symbol-property symbol 'primitive-syntax)
|
(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)
|
(set-object-property! (module-variable the-root-module symbol)
|
||||||
key
|
key
|
||||||
binding))
|
binding))
|
||||||
|
@ -141,8 +150,7 @@
|
||||||
(set-object-property! v key binding)))
|
(set-object-property! v key binding)))
|
||||||
|
|
||||||
(define (getprop symbol key)
|
(define (getprop symbol key)
|
||||||
(let* ((m (current-module))
|
(let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
|
||||||
(v (module-variable m symbol)))
|
|
||||||
(and v (or (object-property v key)
|
(and v (or (object-property v key)
|
||||||
(let ((root-v (module-local-variable the-root-module symbol)))
|
(let ((root-v (module-local-variable the-root-module symbol)))
|
||||||
(and (equal? root-v v)
|
(and (equal? root-v v)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue