diff options
Diffstat (limited to 'module/ice-9/psyntax.scm')
-rw-r--r-- | module/ice-9/psyntax.scm | 44 |
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) |