summaryrefslogtreecommitdiff
path: root/module/ice-9/psyntax.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/psyntax.scm')
-rw-r--r--module/ice-9/psyntax.scm44
1 files changed, 42 insertions, 2 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index d96c3cf5a..1c6a95111 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -850,6 +850,14 @@
(else
(error "unexpected id-var-name" id w n)))))
+ (define transformer-environment
+ (make-fluid
+ (lambda (k)
+ (error "called outside the dynamic extent of a syntax transformer"))))
+
+ (define (with-transformer-environment k)
+ ((fluid-ref transformer-environment) k))
+
;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
@@ -1423,8 +1431,10 @@
(syntax-violation #f "encountered raw symbol in macro output"
(source-wrap e w (wrap-subst w) mod) x))
(else (decorate-source x s)))))
- (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
- (new-mark))))
+ (with-fluids ((transformer-environment
+ (lambda (k) (k e r w s rib mod))))
+ (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
+ (new-mark)))))
(define expand-body
;; In processing the forms of the body, we create a new, empty wrap.
@@ -2541,6 +2551,36 @@
(set! syntax-source
(lambda (x) (source-annotation x)))
+ (set! syntax-local-binding
+ (lambda (id)
+ (arg-check nonsymbol-id? id 'syntax-local-value)
+ (with-transformer-environment
+ (lambda (e r w s rib mod)
+ (define (strip-anti-mark w)
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ ;; output is from original text
+ (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+ ;; output introduced by macro
+ (make-wrap ms (if rib (cons rib s) s)))))
+ (call-with-values (lambda ()
+ (resolve-identifier
+ (syntax-object-expression id)
+ (strip-anti-mark (syntax-object-wrap id))
+ r
+ (syntax-object-module id)
+ ;; FIXME: come up with a better policy for
+ ;; resolve-syntax-parameters
+ #t))
+ (lambda (type value mod)
+ (case type
+ ((lexical) (values 'lexical value))
+ ((macro) (values 'macro value))
+ ((syntax) (values 'pattern-variable value))
+ ((displaced-lexical) (values 'displaced-lexical #f))
+ ((global) (values 'global (cons value mod)))
+ (else (values 'other #f)))))))))
+
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)