summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-06-27 22:54:04 +0200
committerAndy Wingo <wingo@pobox.com>2016-06-27 22:54:04 +0200
commita62d46ffff7b13339178f265fef9171e6b972250 (patch)
tree25fc1ca5d82de28ae73065e5abcef4bde4c9ef90
parente264117e1b73cfbc70f863bb964653dd9ed7a83e (diff)
downloadguile-a62d46ffff7b13339178f265fef9171e6b972250.tar.gz
psyntax can trace expand-time changes to the current module
* module/ice-9/psyntax.scm (expand-top-sequence): Support expand-time changes to the current module. * module/ice-9/psyntax-pp.scm: Regenerate.
-rw-r--r--module/ice-9/psyntax-pp.scm219
-rw-r--r--module/ice-9/psyntax.scm11
2 files changed, 124 insertions, 106 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index e06ae8206..d79766595 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -583,114 +583,123 @@
(lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps))))))
(parse1
(lambda (x r w s m esew mod)
- (call-with-values
- (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f))
- (lambda (type value form e w s mod)
- (let ((key type))
- (cond ((memv key '(define-form))
- (let* ((id (wrap value w mod))
- (label (gen-label))
- (var (if (macro-introduced-identifier? id)
- (fresh-derived-name id x)
- (syntax-object-expression id))))
- (record-definition! id var)
+ (letrec*
+ ((current-module-for-expansion
+ (lambda (mod)
+ (let ((key (car mod)))
+ (if (memv key '(hygiene))
+ (cons 'hygiene (module-name (current-module)))
+ mod)))))
+ (call-with-values
+ (lambda ()
+ (let ((mod (current-module-for-expansion mod)))
+ (syntax-type x r w (source-annotation x) ribcage mod #f)))
+ (lambda (type value form e w s mod)
+ (let ((key type))
+ (cond ((memv key '(define-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (call-with-values
+ (lambda () (resolve-identifier id '(()) r mod #t))
+ (lambda (type* value* mod*)
+ (if (eq? type* 'macro)
+ (top-level-eval-hook
+ (build-global-definition s var (build-void s))
+ mod))
+ (lambda () (build-global-definition s var (expand e r w mod)))))))))
+ ((memv key '(define-syntax-form define-syntax-parameter-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (let ((key m))
+ (cond ((memv key '(c))
+ (cond ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew) (list (lambda () e)) '())))
+ ((memq 'load esew)
+ (list (lambda () (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((memv key '(c&e))
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '())))))
+ ((memv key '(begin-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax
+ value
+ e
+ r
+ w
+ s
+ mod
+ (lambda (forms r w s mod) (parse forms r w s m esew mod))))
+ ((memv key '(eval-when-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
+ (if tmp
+ (apply (lambda (x e1 e2)
+ (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
+ (letrec*
+ ((recurse (lambda (m esew) (parse body r w s m esew mod))))
+ (cond ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
+ (begin
+ (if (memq 'expand when-list)
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (cond ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load)))
+ ((memq m '(c c&e)) (recurse 'c '(load)))
+ (else '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else '())))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ (else
(list (if (eq? m 'c&e)
- (let ((x (build-global-definition s var (expand e r w mod))))
+ (let ((x (expand-expr type value form e r w s mod)))
(top-level-eval-hook x mod)
(lambda () x))
- (call-with-values
- (lambda () (resolve-identifier id '(()) r mod #t))
- (lambda (type* value* mod*)
- (if (eq? type* 'macro)
- (top-level-eval-hook
- (build-global-definition s var (build-void s))
- mod))
- (lambda () (build-global-definition s var (expand e r w mod)))))))))
- ((memv key '(define-syntax-form define-syntax-parameter-form))
- (let* ((id (wrap value w mod))
- (label (gen-label))
- (var (if (macro-introduced-identifier? id)
- (fresh-derived-name id x)
- (syntax-object-expression id))))
- (record-definition! id var)
- (let ((key m))
- (cond ((memv key '(c))
- (cond ((memq 'compile esew)
- (let ((e (expand-install-global var type (expand e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew) (list (lambda () e)) '())))
- ((memq 'load esew)
- (list (lambda () (expand-install-global var type (expand e r w mod)))))
- (else '())))
- ((memv key '(c&e))
- (let ((e (expand-install-global var type (expand e r w mod))))
- (top-level-eval-hook e mod)
- (list (lambda () e))))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (expand-install-global var type (expand e r w mod))
- mod))
- '())))))
- ((memv key '(begin-form))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
- (if tmp
- (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))
- ((memv key '(local-syntax-form))
- (expand-local-syntax
- value
- e
- r
- w
- s
- mod
- (lambda (forms r w s mod) (parse forms r w s m esew mod))))
- ((memv key '(eval-when-form))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
- (if tmp
- (apply (lambda (x e1 e2)
- (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
- (letrec*
- ((recurse (lambda (m esew) (parse body r w s m esew mod))))
- (cond ((eq? m 'e)
- (if (memq 'eval when-list)
- (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod))
- '())))
- ((memq 'load when-list)
- (cond ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (recurse 'c&e '(compile load)))
- ((memq m '(c c&e)) (recurse 'c '(load)))
- (else '())))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod)
- '())
- (else '())))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))
- (else
- (list (if (eq? m 'c&e)
- (let ((x (expand-expr type value form e r w s mod)))
- (top-level-eval-hook x mod)
- (lambda () x))
- (lambda () (expand-expr type value form e r w s mod))))))))))))
+ (lambda () (expand-expr type value form e r w s mod)))))))))))))
(let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
(if (null? exps) (build-void s) (build-sequence s exps)))))))
(expand-install-global
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index e68b4ca7d..88df4c753 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1087,9 +1087,18 @@
(append (parse1 (car body) r w s m esew mod)
exps)))))
(define (parse1 x r w s m esew mod)
+ (define (current-module-for-expansion mod)
+ (case (car mod)
+ ;; If the module was just put in place for hygiene, in a
+ ;; top-level `begin' always recapture the current
+ ;; module. If a user wants to override, then we need to
+ ;; use @@ or similar.
+ ((hygiene) (cons 'hygiene (module-name (current-module))))
+ (else mod)))
(call-with-values
(lambda ()
- (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (let ((mod (current-module-for-expansion mod)))
+ (syntax-type x r w (source-annotation x) ribcage mod #f)))
(lambda (type value form e w s mod)
(case type
((define-form)