mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Fix module scoping for datum->syntax with no identifier

Browse source 
* module/ice-9/psyntax.scm: With the new behavior of datum->syntax which
allows #f for the lexical context, we have the question of what module
to attach to these newly created syntax objects.  In that case we'll
mark down #f as the module, indicating that we know nothing.  We have to
extend a number of other cases to default to the expander's idea of the
current module, if a syntax object has no module scope.

Also, change datum->syntax to attach the empty wrap, not the top wrap.
Attaching the top wrap leads to multiply applying the top mark, as you
recurse into subexpressions.
This commit is contained in:
Andy Wingo 2021-02-24 20:38:14 +01:00
parent e054504fd4
commit 9ade45097c
2 changed files with 124 additions and 115 deletions
Download patch file Download diff file Expand all files Collapse all files

172
module/ice-9/psyntax-pp.scm
View file

@ -384,7 +384,7 @@
((syntax? id) ((syntax? id)
(let ((id (syntax-expression id)) (let ((id (syntax-expression id))
(w1 (syntax-wrap id)) (w1 (syntax-wrap id))
(mod (syntax-module id))) (mod (or (syntax-module id) mod)))
(let ((marks (join-marks (car w) (car w1)))) (let ((marks (join-marks (car w) (car w1))))
(call-with-values (call-with-values
(lambda () (search id (cdr w) marks mod)) (lambda () (search id (cdr w) marks mod))
@ -466,12 +466,12 @@
(syntax-expression n) (syntax-expression n)
(syntax-wrap n) (syntax-wrap n)
r r
(syntax-module n) (or (syntax-module n) mod)
resolve-syntax-parameters?))) resolve-syntax-parameters?)))
((symbol? n) ((symbol? n)
(resolve-global n (if (syntax? id) (syntax-module id) mod))) (resolve-global n (or (and (syntax? id) (syntax-module id)) mod)))
((string? n) ((string? n)
(resolve-lexical n (if (syntax? id) (syntax-module id) mod))) (resolve-lexical n (or (and (syntax? id) (syntax-module id)) mod)))
(else (error "unexpected id-var-name" id w n))))))) (else (error "unexpected id-var-name" id w n)))))))
(transformer-environment (transformer-environment
(make-fluid (make-fluid
@ -524,16 +524,16 @@
(or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
(wrap (lambda (x w defmod) (source-wrap x w #f defmod))) (wrap (lambda (x w defmod) (source-wrap x w #f defmod)))
(wrap-syntax (wrap-syntax
(lambda (x w) (lambda (x w defmod)
(make-syntax (make-syntax
(syntax-expression x) (syntax-expression x)
w w
(syntax-module x) (or (syntax-module x) defmod)
(syntax-source x)))) (syntax-source x))))
(source-wrap (source-wrap
(lambda (x w s defmod) (lambda (x w s defmod)
(cond ((and (null? (car w)) (null? (cdr w)) (not s)) x) (cond ((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)))) ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
((null? x) x) ((null? x) x)
(else (make-syntax x w defmod (or s (source-properties x))))))) (else (make-syntax x w defmod (or s (source-properties x)))))))
(expand-sequence (expand-sequence
@ -557,7 +557,7 @@
(extend-ribcage! (extend-ribcage!
ribcage ribcage
id id
(cons (syntax-module id) (wrap var '((top)) mod)))))) (cons (or (syntax-module id) mod) (wrap var '((top)) mod))))))
(macro-introduced-identifier? (macro-introduced-identifier?
(lambda (id) (not (equal? (car (syntax-wrap id)) '(top))))) (lambda (id) (not (equal? (car (syntax-wrap id)) '(top)))))
(fresh-derived-name (fresh-derived-name
@ -871,7 +871,7 @@
(build-global-reference (build-global-reference
(or (source-annotation (car e)) s) (or (source-annotation (car e)) s)
(if (syntax? value) (syntax-expression value) value) (if (syntax? value) (syntax-expression value) value)
(if (syntax? value) (syntax-module value) mod)) (or (and (syntax? value) (syntax-module value)) mod))
e e
r r
w w
@ -966,11 +966,15 @@
(let ((w (syntax-wrap x))) (let ((w (syntax-wrap x)))
(let ((ms (car w)) (ss (cdr w))) (let ((ms (car w)) (ss (cdr w)))
(if (and (pair? ms) (eq? (car ms) #f)) (if (and (pair? ms) (eq? (car ms) #f))
(wrap-syntax x (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))) (wrap-syntax
x
(cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
mod)
(wrap-syntax (wrap-syntax
x x
(cons (cons m ms) (cons (cons m ms)
(if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))))))) (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
mod)))))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (decorate-source (make-vector n) s))) (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
(let loop ((i 0)) (let loop ((i 0))
@ -986,11 +990,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x s)))))) (else (decorate-source x s))))))
(let* ((t-680b775fb37a463-d7b transformer-environment) (let* ((t-680b775fb37a463-db3 transformer-environment)
(t-680b775fb37a463-d7c (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-db4 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-d7b t-680b775fb37a463-db3
t-680b775fb37a463-d7c t-680b775fb37a463-db4
(lambda () (lambda ()
(rebuild-macro-output (rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod)) (p (source-wrap e (anti-mark w) s mod))
@ -1183,7 +1187,7 @@
(make-syntax (make-syntax
'#{ $sc-ellipsis }# '#{ $sc-ellipsis }#
(syntax-wrap e) (syntax-wrap e)
(syntax-module e) (or (syntax-module e) mod)
#f) #f)
'(()) '(())
r r
@ -1557,11 +1561,9 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-fec (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-feb (cons tmp-680b775fb37a463
tmp-680b775fb37a463-fea) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
(cons tmp-680b775fb37a463-fea
(cons tmp-680b775fb37a463-feb tmp-680b775fb37a463-fec)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1866,9 +1868,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-68f) (map (lambda (tmp-680b775fb37a463-6a4
(cons tmp-680b775fb37a463-68f tmp-680b775fb37a463-6a3
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) tmp-680b775fb37a463-6a2)
(cons tmp-680b775fb37a463-6a2
(cons tmp-680b775fb37a463-6a3 tmp-680b775fb37a463-6a4)))
e2 e2
e1 e1
args))) args)))
@ -1880,11 +1884,11 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6a7 (map (lambda (tmp-680b775fb37a463-6ba
tmp-680b775fb37a463-6a6 tmp-680b775fb37a463-6b9
tmp-680b775fb37a463-6a5) tmp-680b775fb37a463-6b8)
(cons tmp-680b775fb37a463-6a5 (cons tmp-680b775fb37a463-6b8
(cons tmp-680b775fb37a463-6a6 tmp-680b775fb37a463-6a7))) (cons tmp-680b775fb37a463-6b9 tmp-680b775fb37a463-6ba)))
e2 e2
e1 e1
args))) args)))
@ -1907,9 +1911,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-65b tmp-680b775fb37a463-65a tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-66e
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-66d
(cons tmp-680b775fb37a463-65a tmp-680b775fb37a463-65b))) tmp-680b775fb37a463-66c)
(cons tmp-680b775fb37a463-66c
(cons tmp-680b775fb37a463-66d tmp-680b775fb37a463-66e)))
e2 e2
e1 e1
args))) args)))
@ -1921,9 +1927,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-66f) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-66f (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2 e2
e1 e1
args))) args)))
@ -2144,7 +2150,9 @@
(if (and tmp-1 (if (and tmp-1
(apply (lambda (id) (apply (lambda (id)
(and (id? id) (and (id? id)
(equal? (cdr (if (syntax? id) (syntax-module id) mod)) '(guile)))) (equal?
(cdr (or (and (syntax? id) (syntax-module id)) mod))
'(guile))))
tmp-1)) tmp-1))
(apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive))) (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive)))
tmp-1) tmp-1)
@ -2424,10 +2432,8 @@
(lambda* (id datum #:key (source #f #:source)) (lambda* (id datum #:key (source #f #:source))
(make-syntax (make-syntax
datum datum
(if id (syntax-wrap id) '((top))) (if id (syntax-wrap id) '(()))
(if id (and id (syntax-module id))
(syntax-module id)
(cons 'hygiene (module-name (current-module))))
(cond ((not source) (source-properties datum)) (cond ((not source) (source-properties datum))
((and (list? source) (and-map pair? source)) source) ((and (list? source) (and-map pair? source)) source)
(else (syntax-source source)))))) (else (syntax-source source))))))
@ -2478,7 +2484,7 @@
(if (not (nonsymbol-id? x)) (if (not (nonsymbol-id? x))
(syntax-violation 'syntax-module "invalid argument" x))) (syntax-violation 'syntax-module "invalid argument" x)))
(let ((mod (syntax-module id))) (let ((mod (syntax-module id)))
(and (not (equal? mod '(primitive))) (cdr mod))))) (and mod (not (equal? mod '(primitive))) (cdr mod)))))
(syntax-local-binding (syntax-local-binding
(lambda* (id (lambda* (id
#:key #:key
@ -2501,7 +2507,7 @@
(syntax-expression id) (syntax-expression id)
(strip-anti-mark (syntax-wrap id)) (strip-anti-mark (syntax-wrap id))
r r
(syntax-module id) (or (syntax-module id) mod)
resolve-syntax-parameters?)) resolve-syntax-parameters?))
(lambda (type value mod) (lambda (type value mod)
(let ((key type)) (let ((key type))
@ -2517,7 +2523,7 @@
((memv key '(ellipsis)) ((memv key '(ellipsis))
(values (values
'ellipsis 'ellipsis
(wrap-syntax value (anti-mark (syntax-wrap value))))) (wrap-syntax value (anti-mark (syntax-wrap value)) mod)))
(else (values 'other #f))))))))))) (else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers (syntax-locally-bound-identifiers
(lambda (id) (lambda (id)
@ -2547,7 +2553,7 @@
(syntax-expression e) (syntax-expression e)
p p
(join-wraps w (syntax-wrap e)) (join-wraps w (syntax-wrap e))
(syntax-module e))) (or (syntax-module e) mod)))
(else #f)))) (else #f))))
(match-each+ (match-each+
(lambda (e x-pat y-pat z-pat w r mod) (lambda (e x-pat y-pat z-pat w r mod)
@ -2645,7 +2651,7 @@
p p
(join-wraps w (syntax-wrap e)) (join-wraps w (syntax-wrap e))
r r
(syntax-module e))) (or (syntax-module e) mod)))
(else (match* e p w r mod)))))) (else (match* e p w r mod))))))
(set! $sc-dispatch (set! $sc-dispatch
(lambda (e p) (lambda (e p)
@ -2835,11 +2841,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-110c (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-110b (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-110a) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463-110a tmp-680b775fb37a463-110b)
tmp-680b775fb37a463-110c))
template template
pattern pattern
keyword))) keyword)))
@ -2855,9 +2859,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-115f)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463-115f tmp-680b775fb37a463)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-1))
template template
pattern pattern
keyword))) keyword)))
@ -2872,11 +2876,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-113e (map (lambda (tmp-680b775fb37a463-117a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-113d (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-113c) tmp-680b775fb37a463-117a))
(list (cons tmp-680b775fb37a463-113c tmp-680b775fb37a463-113d)
tmp-680b775fb37a463-113e))
template template
pattern pattern
keyword))) keyword)))
@ -2892,11 +2894,9 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-115d (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-115c (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-115b) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463-115b tmp-680b775fb37a463-115c)
tmp-680b775fb37a463-115d))
template template
pattern pattern
keyword))) keyword)))
@ -3044,8 +3044,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-120d) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-120d)) (list "value" tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3068,8 +3068,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-124e)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-124e))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3122,8 +3122,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-122d) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-122d)) (list "value" tmp-680b775fb37a463))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3213,7 +3213,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463)) (apply (lambda (t-680b775fb37a463-12b2)
(cons "vector" t-680b775fb37a463-12b2))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3223,7 +3224,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) (k (map (lambda (tmp-680b775fb37a463-12be)
(list "quote" tmp-680b775fb37a463-12be))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3234,8 +3236,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463 tmp)) (let ((t-680b775fb37a463-12cd tmp))
(list "list->vector" t-680b775fb37a463))))))))))))))))) (list "list->vector" t-680b775fb37a463-12cd)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3248,9 +3250,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12a0) (apply (lambda (t-680b775fb37a463-12dc)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12a0)) t-680b775fb37a463-12dc))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3266,10 +3268,10 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12b4 t-680b775fb37a463-12b3) (apply (lambda (t-680b775fb37a463-12f0 t-680b775fb37a463-12ef)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12b4 t-680b775fb37a463-12f0
t-680b775fb37a463-12b3)) t-680b775fb37a463-12ef))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3282,9 +3284,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12c0) (apply (lambda (t-680b775fb37a463-12fc)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12c0)) t-680b775fb37a463-12fc))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3297,9 +3299,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12cc) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12cc)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3310,9 +3312,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12d8 tmp)) (let ((t-680b775fb37a463 tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12d8)))) t-680b775fb37a463))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

67
module/ice-9/psyntax.scm
View file

@ -760,7 +760,7 @@
((syntax? id) ((syntax? id)
(let ((id (syntax-expression id)) (let ((id (syntax-expression id))
(w1 (syntax-wrap id)) (w1 (syntax-wrap id))
(mod (syntax-module id))) (mod (or (syntax-module id) mod)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (lambda () (search id (wrap-subst w) marks mod)) (call-with-values (lambda () (search id (wrap-subst w) marks mod))
(lambda (new-id marks) (lambda (new-id marks)
@ -902,15 +902,15 @@
(resolve-identifier (syntax-expression n) (resolve-identifier (syntax-expression n)
(syntax-wrap n) (syntax-wrap n)
r r
(syntax-module n) (or (syntax-module n) mod)
resolve-syntax-parameters?)))) resolve-syntax-parameters?))))
((symbol? n) ((symbol? n)
(resolve-global n (if (syntax? id) (resolve-global n (or (and (syntax? id)
(syntax-module id) (syntax-module id))
mod))) mod)))
((string? n) ((string? n)
(resolve-lexical n (if (syntax? id) (resolve-lexical n (or (and (syntax? id)
(syntax-module id) (syntax-module id))
mod))) mod)))
(else (else
(error "unexpected id-var-name" id w n))))) (error "unexpected id-var-name" id w n)))))
@ -1012,18 +1012,21 @@
(lambda (x w defmod) (lambda (x w defmod)
(source-wrap x w #f defmod))) (source-wrap x w #f defmod)))
(define (wrap-syntax x w) (define (wrap-syntax x w defmod)
(make-syntax (syntax-expression x) (make-syntax (syntax-expression x)
w w
(syntax-module x) (or (syntax-module x) defmod)
(syntax-source x))) (syntax-source x)))
(define source-wrap (define (source-wrap x w s defmod)
(lambda (x w s defmod) (cond
(cond ((and (null? (wrap-marks w))
((and (null? (wrap-marks w)) (null? (wrap-subst w)) (not s)) x) (null? (wrap-subst w))
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)))) (not defmod)
((null? x) x) (not s))
(else (make-syntax x w defmod (or s (source-properties x))))))) x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
((null? x) x)
(else (make-syntax x w defmod (or s (source-properties x))))))
;; expanding ;; expanding
@ -1064,7 +1067,7 @@
;; the special case of names that are pairs. See the ;; the special case of names that are pairs. See the
;; comments in id-var-name for more. ;; comments in id-var-name for more.
(extend-ribcage! ribcage id (extend-ribcage! ribcage id
(cons (syntax-module id) (cons (or (syntax-module id) mod)
(wrap var top-wrap mod))))) (wrap var top-wrap mod)))))
(define (macro-introduced-identifier? id) (define (macro-introduced-identifier? id)
(not (equal? (wrap-marks (syntax-wrap id)) '(top)))) (not (equal? (wrap-marks (syntax-wrap id)) '(top))))
@ -1410,8 +1413,8 @@
(if (syntax? value) (if (syntax? value)
(syntax-expression value) (syntax-expression value)
value) value)
(if (syntax? value) (or (and (syntax? value)
(syntax-module value) (syntax-module value))
mod)) mod))
e r w s mod)) e r w s mod))
((primitive-call) ((primitive-call)
@ -1510,14 +1513,16 @@
(make-wrap (cdr ms) (make-wrap (cdr ms)
(if rib (if rib
(cons rib (cdr ss)) (cons rib (cdr ss))
(cdr ss)))) (cdr ss)))
mod)
;; output introduced by macro ;; output introduced by macro
(wrap-syntax (wrap-syntax
x x
(make-wrap (cons m ms) (make-wrap (cons m ms)
(if rib (if rib
(cons rib (cons 'shift ss)) (cons rib (cons 'shift ss))
(cons 'shift ss)))))))) (cons 'shift ss)))
mod)))))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (let* ((n (vector-length x))
@ -1752,7 +1757,7 @@
(lambda () (resolve-identifier (lambda () (resolve-identifier
(make-syntax '#{ $sc-ellipsis }# (make-syntax '#{ $sc-ellipsis }#
(syntax-wrap e) (syntax-wrap e)
(syntax-module e) (or (syntax-module e) mod)
#f) #f)
empty-wrap r mod #f)) empty-wrap r mod #f))
(lambda (type value mod) (lambda (type value mod)
@ -2477,8 +2482,8 @@
(syntax-case e (@@ primitive) (syntax-case e (@@ primitive)
((_ primitive id) ((_ primitive id)
(and (id? #'id) (and (id? #'id)
(equal? (cdr (if (syntax? #'id) (equal? (cdr (or (and (syntax? #'id)
(syntax-module #'id) (syntax-module #'id))
mod)) mod))
'(guile))) '(guile)))
;; Strip the wrap from the identifier and return top-wrap ;; Strip the wrap from the identifier and return top-wrap
@ -2728,10 +2733,10 @@
(make-syntax datum (make-syntax datum
(if id (if id
(syntax-wrap id) (syntax-wrap id)
top-wrap) empty-wrap)
(if id (if id
(syntax-module id) (syntax-module id)
(cons 'hygiene (module-name (current-module)))) #f)
(cond (cond
((not source) (source-properties datum)) ((not source) (source-properties datum))
((and (list? source) (and-map pair? source)) source) ((and (list? source) (and-map pair? source)) source)
@ -2778,7 +2783,8 @@
(define (%syntax-module id) (define (%syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module) (arg-check nonsymbol-id? id 'syntax-module)
(let ((mod (syntax-module id))) (let ((mod (syntax-module id)))
(and (not (equal? mod '(primitive))) (and mod
(not (equal? mod '(primitive)))
(cdr mod)))) (cdr mod))))
(define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t)) (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
@ -2797,7 +2803,7 @@
(syntax-expression id) (syntax-expression id)
(strip-anti-mark (syntax-wrap id)) (strip-anti-mark (syntax-wrap id))
r r
(syntax-module id) (or (syntax-module id) mod)
resolve-syntax-parameters?)) resolve-syntax-parameters?))
(lambda (type value mod) (lambda (type value mod)
(case type (case type
@ -2812,7 +2818,8 @@
(values 'global (cons value (cdr mod))))) (values 'global (cons value (cdr mod)))))
((ellipsis) ((ellipsis)
(values 'ellipsis (values 'ellipsis
(wrap-syntax value (anti-mark (syntax-wrap value))))) (wrap-syntax value (anti-mark (syntax-wrap value))
mod)))
(else (values 'other #f)))))))) (else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id) (define (syntax-locally-bound-identifiers id)
@ -2866,7 +2873,7 @@
(match-each (syntax-expression e) (match-each (syntax-expression e)
p p
(join-wraps w (syntax-wrap e)) (join-wraps w (syntax-wrap e))
(syntax-module e))) (or (syntax-module e) mod)))
(else #f)))) (else #f))))
(define match-each+ (define match-each+
@ -2979,7 +2986,7 @@
p p
(join-wraps w (syntax-wrap e)) (join-wraps w (syntax-wrap e))
r r
(syntax-module e))) (or (syntax-module e) mod)))
(else (match* e p w r mod))))) (else (match* e p w r mod)))))
(set! $sc-dispatch (set! $sc-dispatch