mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Fix race when expanding syntax-parameterize and define-syntax-parameter

Browse source 
* module/ice-9/psyntax.scm (put-global-definition-hook)
  (get-global-definition-hook): Inline into uses.
  (make-binding): Change format of lexically defined or rebound syntax
  parameters to just be the transformer, not a list of the transformer.
  (resolve-identifier, expand-install-global, expand-body)
  (syntax-parameterize): Adapt to use the variable object (box) holding
  the top-level syntax parameter as the "key" for lookups into the
  lexical environment, instead of a fresh object associated with the
  syntax transformer.
* module/ice-9/psyntax-pp.scm: Regenerate.

Fixes #27476, a horrible race when one thread is expanding a
syntax-parameterize form including uses, and another thread is expanding
the corresponding define-syntax-parameter.  See
https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27476#102.
This commit is contained in:
Andy Wingo 2019-02-22 15:25:21 +01:00
parent 27ffbfb023
commit 2dccec9f55
2 changed files with 196 additions and 172 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -120,26 +120,6 @@
(session-id (session-id
(let ((v (module-variable (current-module) 'syntax-session-id))) (let ((v (module-variable (current-module) 'syntax-session-id)))
(lambda () ((variable-ref v))))) (lambda () ((variable-ref v)))))
(put-global-definition-hook
(lambda (symbol type val)
(module-define!
(current-module)
symbol
(make-syntax-transformer symbol type val))))
(get-global-definition-hook
(lambda (symbol module)
(if (and (not module) (current-module))
(warn "module system is booted, we should have a module" symbol))
(and (not (equal? module '(primitive)))
(let ((v (module-variable
(if module (resolve-module (cdr module)) (current-module))
symbol)))
(and v
(variable-bound? v)
(let ((val (variable-ref v)))
(and (macro? val)
(macro-type val)
(cons (macro-type val) (macro-binding val)))))))))
(decorate-source (decorate-source
(lambda (e s) (lambda (e s)
(if (and s (supports-source-properties? e)) (if (and s (supports-source-properties? e))
@ -297,7 +277,11 @@
(cons a (macros-only-env (cdr r))) (cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r))))))) (macros-only-env (cdr r)))))))
(global-extend (global-extend
(lambda (type sym val) (put-global-definition-hook sym type val))) (lambda (type sym val)
(module-define!
(current-module)
sym
(make-syntax-transformer sym type val))))
(nonsymbol-id? (nonsymbol-id?
(lambda (x) (lambda (x)
(and (syntax-object? x) (symbol? (syntax-object-expression x))))) (and (syntax-object? x) (symbol? (syntax-object-expression x)))))
@ -459,23 +443,37 @@
(resolve-identifier (resolve-identifier
(lambda (id w r mod resolve-syntax-parameters?) (lambda (id w r mod resolve-syntax-parameters?)
(letrec* (letrec*
((resolve-syntax-parameters ((resolve-global
(lambda (b)
(if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter))
(or (assq-ref r (cdr b)) (cons 'macro (car (cdr b))))
b)))
(resolve-global
(lambda (var mod) (lambda (var mod)
(let ((b (resolve-syntax-parameters (if (and (not mod) (current-module))
(or (get-global-definition-hook var mod) '(global))))) (warn "module system is booted, we should have a module" var))
(if (eq? (car b) 'global) (let ((v (and (not (equal? mod '(primitive)))
(values 'global var mod) (module-variable
(values (car b) (cdr b) mod))))) (if mod (resolve-module (cdr mod)) (current-module))
var))))
(if (and v (variable-bound? v) (macro? (variable-ref v)))
(let* ((m (variable-ref v))
(type (macro-type m))
(trans (macro-binding m))
(trans (if (pair? trans) (car trans) trans)))
(if (eq? type 'syntax-parameter)
(if resolve-syntax-parameters?
(let ((lexical (assq-ref r v)))
(values 'macro (if lexical (cdr lexical) trans) mod))
(values type v mod))
(values type trans mod)))
(values 'global var mod)))))
(resolve-lexical (resolve-lexical
(lambda (label mod) (lambda (label mod)
(let ((b (resolve-syntax-parameters (let ((b (assq-ref r label)))
(or (assq-ref r label) '(displaced-lexical))))) (if b
(values (car b) (cdr b) mod))))) (let ((type (car b)) (value (cdr b)))
(if (eq? type 'syntax-parameter)
(if resolve-syntax-parameters?
(values 'macro value mod)
(values type label mod))
(values type value mod)))
(values 'displaced-lexical #f #f))))))
(let ((n (id-var-name id w mod))) (let ((n (id-var-name id w mod)))
(cond ((syntax-object? n) (cond ((syntax-object? n)
(if (not (eq? n id)) (if (not (eq? n id))
@ -726,11 +724,13 @@
(build-primcall (build-primcall
#f #f
'make-syntax-transformer 'make-syntax-transformer
(if (eq? type 'define-syntax-parameter-form) (list (build-data #f name)
(list (build-data #f name) (build-data
(build-data #f 'syntax-parameter) #f
(build-primcall #f 'list (list e))) (if (eq? type 'define-syntax-parameter-form)
(list (build-data #f name) (build-data #f 'macro) e)))))) 'syntax-parameter
'macro))
e)))))
(parse-when-list (parse-when-list
(lambda (e when-list) (lambda (e when-list)
(let ((result (strip when-list '(())))) (let ((result (strip when-list '(()))))
@ -1010,11 +1010,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-7fa transformer-environment) (let* ((t-680b775fb37a463-7d8 transformer-environment)
(t-680b775fb37a463-7fb (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-7d9 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-7fa t-680b775fb37a463-7d8
t-680b775fb37a463-7fb t-680b775fb37a463-7d9
(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))
@ -1072,7 +1072,7 @@
(extend-env (extend-env
(list label) (list label)
(list (cons 'syntax-parameter (list (cons 'syntax-parameter
(list (eval-local-transformer (expand e trans-r w mod) mod)))) (eval-local-transformer (expand e trans-r w mod) mod)))
(cdr r))) (cdr r)))
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((memv key '(begin-form)) ((memv key '(begin-form))
@ -1550,11 +1550,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-aeb (map (lambda (tmp-680b775fb37a463-ac9
tmp-680b775fb37a463-aea tmp-680b775fb37a463-ac8
tmp-680b775fb37a463-ae9) tmp-680b775fb37a463-ac7)
(cons tmp-680b775fb37a463-ae9 (cons tmp-680b775fb37a463-ac7
(cons tmp-680b775fb37a463-aea tmp-680b775fb37a463-aeb))) (cons tmp-680b775fb37a463-ac8 tmp-680b775fb37a463-ac9)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1630,7 +1630,8 @@
(bindings (bindings
(let ((trans-r (macros-only-env r))) (let ((trans-r (macros-only-env r)))
(map (lambda (x) (map (lambda (x)
(cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) (cons 'syntax-parameter
(eval-local-transformer (expand x trans-r w mod) mod)))
val)))) val))))
(expand-body (expand-body
(cons e1 e2) (cons e1 e2)
@ -1854,11 +1855,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-cb8 (map (lambda (tmp-680b775fb37a463-c96
tmp-680b775fb37a463-cb7 tmp-680b775fb37a463-c95
tmp-680b775fb37a463-cb6) tmp-680b775fb37a463-c94)
(cons tmp-680b775fb37a463-cb6 (cons tmp-680b775fb37a463-c94
(cons tmp-680b775fb37a463-cb7 tmp-680b775fb37a463-cb8))) (cons tmp-680b775fb37a463-c95 tmp-680b775fb37a463-c96)))
e2 e2
e1 e1
args))) args)))
@ -1870,11 +1871,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-cce (map (lambda (tmp-680b775fb37a463-cac
tmp-680b775fb37a463-ccd tmp-680b775fb37a463-cab
tmp-680b775fb37a463-ccc) tmp-680b775fb37a463-caa)
(cons tmp-680b775fb37a463-ccc (cons tmp-680b775fb37a463-caa
(cons tmp-680b775fb37a463-ccd tmp-680b775fb37a463-cce))) (cons tmp-680b775fb37a463-cab tmp-680b775fb37a463-cac)))
e2 e2
e1 e1
args))) args)))
@ -1897,11 +1898,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-cee (map (lambda (tmp-680b775fb37a463-ccc
tmp-680b775fb37a463-ced tmp-680b775fb37a463-ccb
tmp-680b775fb37a463-cec) tmp-680b775fb37a463-cca)
(cons tmp-680b775fb37a463-cec (cons tmp-680b775fb37a463-cca
(cons tmp-680b775fb37a463-ced tmp-680b775fb37a463-cee))) (cons tmp-680b775fb37a463-ccb tmp-680b775fb37a463-ccc)))
e2 e2
e1 e1
args))) args)))
@ -1913,11 +1914,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-d04 (map (lambda (tmp-680b775fb37a463-ce2
tmp-680b775fb37a463-d03 tmp-680b775fb37a463-ce1
tmp-680b775fb37a463-d02) tmp-680b775fb37a463-ce0)
(cons tmp-680b775fb37a463-d02 (cons tmp-680b775fb37a463-ce0
(cons tmp-680b775fb37a463-d03 tmp-680b775fb37a463-d04))) (cons tmp-680b775fb37a463-ce1 tmp-680b775fb37a463-ce2)))
e2 e2
e1 e1
args))) args)))
@ -2497,8 +2498,7 @@
(let ((key type)) (let ((key type))
(cond ((memv key '(lexical)) (values 'lexical value)) (cond ((memv key '(lexical)) (values 'lexical value))
((memv key '(macro)) (values 'macro value)) ((memv key '(macro)) (values 'macro value))
((memv key '(syntax-parameter)) ((memv key '(syntax-parameter)) (values 'syntax-parameter value))
(values 'syntax-parameter (car value)))
((memv key '(syntax)) (values 'pattern-variable value)) ((memv key '(syntax)) (values 'pattern-variable value))
((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
((memv key '(global)) ((memv key '(global))
@ -2850,9 +2850,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-114f
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-114e)
(list (cons tmp-680b775fb37a463-114e tmp-680b775fb37a463-114f)
tmp-680b775fb37a463))
template template
pattern pattern
keyword))) keyword)))
@ -2867,11 +2869,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-118b (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-118a (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-118a)
tmp-680b775fb37a463-118b))
template template
pattern pattern
keyword))) keyword)))
@ -2887,11 +2887,9 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11aa (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-11a9 (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-11a8) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a9)
tmp-680b775fb37a463-11aa))
template template
pattern pattern
keyword))) keyword)))
@ -3039,8 +3037,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-11f3)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-11f3))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3063,8 +3061,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-121a) (map (lambda (tmp-680b775fb37a463-11f8)
(list "value" tmp-680b775fb37a463-121a)) (list "value" tmp-680b775fb37a463-11f8))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3098,7 +3096,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463)) (map (lambda (tmp-680b775fb37a463-120e)
(list "value" tmp-680b775fb37a463-120e))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3208,8 +3207,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-127e) (apply (lambda (t-680b775fb37a463-125c)
(cons "vector" t-680b775fb37a463-127e)) (cons "vector" t-680b775fb37a463-125c))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3219,8 +3218,7 @@
(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-128a) (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
(list "quote" tmp-680b775fb37a463-128a))
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))))
@ -3245,9 +3243,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-12a8) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12a8)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3263,10 +3261,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-12bc t-680b775fb37a463-12bb) (apply (lambda (t-680b775fb37a463-129a t-680b775fb37a463)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12bc t-680b775fb37a463-129a
t-680b775fb37a463-12bb)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3279,9 +3277,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-12c8) (apply (lambda (t-680b775fb37a463-12a6)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12c8)) t-680b775fb37a463-12a6))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3294,9 +3292,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-12d4) (apply (lambda (t-680b775fb37a463-12b2)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12d4)) t-680b775fb37a463-12b2))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3307,9 +3305,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12e0 tmp)) (let ((t-680b775fb37a463-12be tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12e0)))) t-680b775fb37a463-12be))))
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

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

@ -1,7 +1,7 @@
;;;; -*-scheme-*- ;;;; -*-scheme-*-
;;;; ;;;;
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011, ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
;;;; 2012, 2013, 2015, 2016 Free Software Foundation, Inc. ;;;; 2012, 2013, 2015, 2016, 2019 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -292,29 +292,7 @@
(define session-id (define session-id
(let ((v (module-variable (current-module) 'syntax-session-id))) (let ((v (module-variable (current-module) 'syntax-session-id)))
(lambda () (lambda ()
((variable-ref v))))) ((variable-ref v))))))
(define put-global-definition-hook
(lambda (symbol type val)
(module-define! (current-module)
symbol
(make-syntax-transformer symbol type val))))
(define get-global-definition-hook
(lambda (symbol module)
(if (and (not module) (current-module))
(warn "module system is booted, we should have a module" symbol))
(and (not (equal? module '(primitive)))
(let ((v (module-variable (if module
(resolve-module (cdr module))
(current-module))
symbol)))
(and v (variable-bound? v)
(let ((val (variable-ref v)))
(and (macro? val) (macro-type val)
(cons (macro-type val)
(macro-binding val))))))))))
(define (decorate-source e s) (define (decorate-source e s)
(if (and s (supports-source-properties? e)) (if (and s (supports-source-properties? e))
@ -513,11 +491,10 @@
;; wrap : id --> label ;; wrap : id --> label
;; env : label --> <element> ;; env : label --> <element>
;; environments are represented in two parts: a lexical part and a global ;; environments are represented in two parts: a lexical part and a
;; part. The lexical part is a simple list of associations from labels ;; global part. The lexical part is a simple list of associations
;; to bindings. The global part is implemented by ;; from labels to bindings. The global part is implemented by
;; {put,get}-global-definition-hook and associates symbols with ;; Guile's module system and associates symbols with bindings.
;; bindings.
;; global (assumed global variable) and displaced-lexical (see below) ;; global (assumed global variable) and displaced-lexical (see below)
;; do not show up in any environment; instead, they are fabricated by ;; do not show up in any environment; instead, they are fabricated by
@ -528,7 +505,7 @@
;; identifier bindings include a type and a value ;; identifier bindings include a type and a value
;; <binding> ::= (macro . <procedure>) macros ;; <binding> ::= (macro . <procedure>) macros
;; (syntax-parameter . (<procedure>)) syntax parameters ;; (syntax-parameter . <procedure>) syntax parameters
;; (core . <procedure>) core forms ;; (core . <procedure>) core forms
;; (module-ref . <procedure>) @ or @@ ;; (module-ref . <procedure>) @ or @@
;; (begin) begin ;; (begin) begin
@ -610,7 +587,9 @@
(define global-extend (define global-extend
(lambda (type sym val) (lambda (type sym val)
(put-global-definition-hook sym type val))) (module-define! (current-module)
sym
(make-syntax-transformer sym type val))))
;; Conceptually, identifiers are always syntax objects. Internally, ;; Conceptually, identifiers are always syntax objects. Internally,
@ -892,27 +871,75 @@
results))))))) results)))))))
(scan (wrap-subst w) '()))) (scan (wrap-subst w) '())))
;; Returns three values: binding type, binding value, the module (for ;; Returns three values: binding type, binding value, and the module
;; resolving toplevel vars). ;; (for resolving toplevel vars).
(define (resolve-identifier id w r mod resolve-syntax-parameters?) (define (resolve-identifier id w r mod resolve-syntax-parameters?)
(define (resolve-syntax-parameters b)
(if (and resolve-syntax-parameters?
(eq? (binding-type b) 'syntax-parameter))
(or (assq-ref r (binding-value b))
(make-binding 'macro (car (binding-value b))))
b))
(define (resolve-global var mod) (define (resolve-global var mod)
(let ((b (resolve-syntax-parameters (when (and (not mod) (current-module))
(or (get-global-definition-hook var mod) (warn "module system is booted, we should have a module" var))
(make-binding 'global))))) (let ((v (and (not (equal? mod '(primitive)))
(if (eq? (binding-type b) 'global) (module-variable (if mod
(values 'global var mod) (resolve-module (cdr mod))
(values (binding-type b) (binding-value b) mod)))) (current-module))
var))))
;; The expander needs to know when a top-level definition from
;; outside the compilation unit is a macro.
;;
;; Additionally if a macro is actually a syntax-parameter, we
;; might need to resolve its current binding. If the syntax
;; parameter is locally bound (via syntax-parameterize), then
;; its variable will be present in `r', the expand-time
;; environment. It's a kind of double lookup: first we see
;; that a name is bound to a syntax parameter, then we look
;; for the current binding of the syntax parameter.
;;
;; We use the variable (box) holding the syntax parameter
;; definition as the key for the second lookup. We use the
;; variable for two reasons:
;;
;; 1. If the syntax parameter is redefined in parallel
;; (perhaps via a parallel module compilation), the
;; redefinition keeps the same variable. We don't want to
;; use a "key" that could change during a redefinition. See
;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27476.
;;
;; 2. Using the variable instead of its (symname, modname)
;; pair allows for syntax parameters to be renamed or
;; aliased while preserving the syntax parameter's identity.
;;
(if (and v (variable-bound? v) (macro? (variable-ref v)))
(let* ((m (variable-ref v))
(type (macro-type m))
(trans (macro-binding m))
(trans (if (pair? trans) (car trans) trans)))
(if (eq? type 'syntax-parameter)
(if resolve-syntax-parameters?
(let ((lexical (assq-ref r v)))
;; A resolved syntax parameter is
;; indistinguishable from a macro.
(values 'macro
(if lexical
(binding-value lexical)
trans)
mod))
;; Return box as value for use in second lookup.
(values type v mod))
(values type trans mod)))
(values 'global var mod))))
(define (resolve-lexical label mod) (define (resolve-lexical label mod)
(let ((b (resolve-syntax-parameters (let ((b (assq-ref r label)))
(or (assq-ref r label) (if b
(make-binding 'displaced-lexical))))) (let ((type (binding-type b))
(values (binding-type b) (binding-value b) mod))) (value (binding-value b)))
(if (eq? type 'syntax-parameter)
(if resolve-syntax-parameters?
(values 'macro value mod)
;; If the syntax parameter was defined within
;; this compilation unit, use its label as its
;; lookup key.
(values type label mod))
(values type value mod)))
(values 'displaced-lexical #f #f))))
(let ((n (id-var-name id w mod))) (let ((n (id-var-name id w mod)))
(cond (cond
((syntax-object? n) ((syntax-object? n)
@ -1245,13 +1272,12 @@
(build-primcall (build-primcall
no-source no-source
'make-syntax-transformer 'make-syntax-transformer
(if (eq? type 'define-syntax-parameter-form) (list (build-data no-source name)
(list (build-data no-source name) (build-data no-source
(build-data no-source 'syntax-parameter) (if (eq? type 'define-syntax-parameter-form)
(build-primcall no-source 'list (list e))) 'syntax-parameter
(list (build-data no-source name) 'macro))
(build-data no-source 'macro) e)))))
e))))))
(define parse-when-list (define parse-when-list
(lambda (e when-list) (lambda (e when-list)
@ -1641,7 +1667,7 @@
(cdr r))) (cdr r)))
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((define-syntax-parameter-form) ((define-syntax-parameter-form)
;; Same as define-syntax-form, but different format of the binding. ;; Same as define-syntax-form, different binding type though.
(let ((id (wrap value w mod)) (let ((id (wrap value w mod))
(label (gen-label)) (label (gen-label))
(trans-r (macros-only-env er))) (trans-r (macros-only-env er)))
@ -1650,9 +1676,9 @@
(list label) (list label)
(list (make-binding (list (make-binding
'syntax-parameter 'syntax-parameter
(list (eval-local-transformer (eval-local-transformer
(expand e trans-r w mod) (expand e trans-r w mod)
mod)))) mod)))
(cdr r))) (cdr r)))
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((begin-form) ((begin-form)
@ -2053,14 +2079,14 @@
(let ((trans-r (macros-only-env r))) (let ((trans-r (macros-only-env r)))
(map (lambda (x) (map (lambda (x)
(make-binding (make-binding
'macro 'syntax-parameter
(eval-local-transformer (expand x trans-r w mod) mod))) (eval-local-transformer (expand x trans-r w mod) mod)))
#'(val ...))))) #'(val ...)))))
(expand-body #'(e1 e2 ...) (expand-body #'(e1 e2 ...)
(source-wrap e w s mod) (source-wrap e w s mod)
(extend-env names bindings r) (extend-env names bindings r)
w w
mod))) mod)))
(_ (syntax-violation 'syntax-parameterize "bad syntax" (_ (syntax-violation 'syntax-parameterize "bad syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod))))))
@ -2799,7 +2825,7 @@
(case type (case type
((lexical) (values 'lexical value)) ((lexical) (values 'lexical value))
((macro) (values 'macro value)) ((macro) (values 'macro value))
((syntax-parameter) (values 'syntax-parameter (car value))) ((syntax-parameter) (values 'syntax-parameter value))
((syntax) (values 'pattern-variable value)) ((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f)) ((displaced-lexical) (values 'displaced-lexical #f))
((global) ((global)