mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
Fix race when expanding syntax-parameterize and define-syntax-parameter
* 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
parent
27ffbfb023
commit
2dccec9f55
2 changed files with 196 additions and 172 deletions
|
|
@ -120,26 +120,6 @@
|
|||
(session-id
|
||||
(let ((v (module-variable (current-module) 'syntax-session-id)))
|
||||
(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
|
||||
(lambda (e s)
|
||||
(if (and s (supports-source-properties? e))
|
||||
|
|
@ -297,7 +277,11 @@
|
|||
(cons a (macros-only-env (cdr r)))
|
||||
(macros-only-env (cdr r)))))))
|
||||
(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?
|
||||
(lambda (x)
|
||||
(and (syntax-object? x) (symbol? (syntax-object-expression x)))))
|
||||
|
|
@ -459,23 +443,37 @@
|
|||
(resolve-identifier
|
||||
(lambda (id w r mod resolve-syntax-parameters?)
|
||||
(letrec*
|
||||
((resolve-syntax-parameters
|
||||
(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
|
||||
((resolve-global
|
||||
(lambda (var mod)
|
||||
(let ((b (resolve-syntax-parameters
|
||||
(or (get-global-definition-hook var mod) '(global)))))
|
||||
(if (eq? (car b) 'global)
|
||||
(values 'global var mod)
|
||||
(values (car b) (cdr b) mod)))))
|
||||
(if (and (not mod) (current-module))
|
||||
(warn "module system is booted, we should have a module" var))
|
||||
(let ((v (and (not (equal? mod '(primitive)))
|
||||
(module-variable
|
||||
(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
|
||||
(lambda (label mod)
|
||||
(let ((b (resolve-syntax-parameters
|
||||
(or (assq-ref r label) '(displaced-lexical)))))
|
||||
(values (car b) (cdr b) mod)))))
|
||||
(let ((b (assq-ref r label)))
|
||||
(if b
|
||||
(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)))
|
||||
(cond ((syntax-object? n)
|
||||
(if (not (eq? n id))
|
||||
|
|
@ -726,11 +724,13 @@
|
|||
(build-primcall
|
||||
#f
|
||||
'make-syntax-transformer
|
||||
(if (eq? type 'define-syntax-parameter-form)
|
||||
(list (build-data #f name)
|
||||
(build-data #f 'syntax-parameter)
|
||||
(build-primcall #f 'list (list e)))
|
||||
(list (build-data #f name) (build-data #f 'macro) e))))))
|
||||
(list (build-data #f name)
|
||||
(build-data
|
||||
#f
|
||||
(if (eq? type 'define-syntax-parameter-form)
|
||||
'syntax-parameter
|
||||
'macro))
|
||||
e)))))
|
||||
(parse-when-list
|
||||
(lambda (e when-list)
|
||||
(let ((result (strip when-list '(()))))
|
||||
|
|
@ -1010,11 +1010,11 @@
|
|||
(source-wrap e w (cdr w) mod)
|
||||
x))
|
||||
(else (decorate-source x s))))))
|
||||
(let* ((t-680b775fb37a463-7fa transformer-environment)
|
||||
(t-680b775fb37a463-7fb (lambda (k) (k e r w s rib mod))))
|
||||
(let* ((t-680b775fb37a463-7d8 transformer-environment)
|
||||
(t-680b775fb37a463-7d9 (lambda (k) (k e r w s rib mod))))
|
||||
(with-fluid*
|
||||
t-680b775fb37a463-7fa
|
||||
t-680b775fb37a463-7fb
|
||||
t-680b775fb37a463-7d8
|
||||
t-680b775fb37a463-7d9
|
||||
(lambda ()
|
||||
(rebuild-macro-output
|
||||
(p (source-wrap e (anti-mark w) s mod))
|
||||
|
|
@ -1072,7 +1072,7 @@
|
|||
(extend-env
|
||||
(list label)
|
||||
(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)))
|
||||
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
|
||||
((memv key '(begin-form))
|
||||
|
|
@ -1550,11 +1550,11 @@
|
|||
s
|
||||
mod
|
||||
get-formals
|
||||
(map (lambda (tmp-680b775fb37a463-aeb
|
||||
tmp-680b775fb37a463-aea
|
||||
tmp-680b775fb37a463-ae9)
|
||||
(cons tmp-680b775fb37a463-ae9
|
||||
(cons tmp-680b775fb37a463-aea tmp-680b775fb37a463-aeb)))
|
||||
(map (lambda (tmp-680b775fb37a463-ac9
|
||||
tmp-680b775fb37a463-ac8
|
||||
tmp-680b775fb37a463-ac7)
|
||||
(cons tmp-680b775fb37a463-ac7
|
||||
(cons tmp-680b775fb37a463-ac8 tmp-680b775fb37a463-ac9)))
|
||||
e2*
|
||||
e1*
|
||||
args*)))
|
||||
|
|
@ -1630,7 +1630,8 @@
|
|||
(bindings
|
||||
(let ((trans-r (macros-only-env r)))
|
||||
(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))))
|
||||
(expand-body
|
||||
(cons e1 e2)
|
||||
|
|
@ -1854,11 +1855,11 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-cb8
|
||||
tmp-680b775fb37a463-cb7
|
||||
tmp-680b775fb37a463-cb6)
|
||||
(cons tmp-680b775fb37a463-cb6
|
||||
(cons tmp-680b775fb37a463-cb7 tmp-680b775fb37a463-cb8)))
|
||||
(map (lambda (tmp-680b775fb37a463-c96
|
||||
tmp-680b775fb37a463-c95
|
||||
tmp-680b775fb37a463-c94)
|
||||
(cons tmp-680b775fb37a463-c94
|
||||
(cons tmp-680b775fb37a463-c95 tmp-680b775fb37a463-c96)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1870,11 +1871,11 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-cce
|
||||
tmp-680b775fb37a463-ccd
|
||||
tmp-680b775fb37a463-ccc)
|
||||
(cons tmp-680b775fb37a463-ccc
|
||||
(cons tmp-680b775fb37a463-ccd tmp-680b775fb37a463-cce)))
|
||||
(map (lambda (tmp-680b775fb37a463-cac
|
||||
tmp-680b775fb37a463-cab
|
||||
tmp-680b775fb37a463-caa)
|
||||
(cons tmp-680b775fb37a463-caa
|
||||
(cons tmp-680b775fb37a463-cab tmp-680b775fb37a463-cac)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1897,11 +1898,11 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-cee
|
||||
tmp-680b775fb37a463-ced
|
||||
tmp-680b775fb37a463-cec)
|
||||
(cons tmp-680b775fb37a463-cec
|
||||
(cons tmp-680b775fb37a463-ced tmp-680b775fb37a463-cee)))
|
||||
(map (lambda (tmp-680b775fb37a463-ccc
|
||||
tmp-680b775fb37a463-ccb
|
||||
tmp-680b775fb37a463-cca)
|
||||
(cons tmp-680b775fb37a463-cca
|
||||
(cons tmp-680b775fb37a463-ccb tmp-680b775fb37a463-ccc)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1913,11 +1914,11 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-d04
|
||||
tmp-680b775fb37a463-d03
|
||||
tmp-680b775fb37a463-d02)
|
||||
(cons tmp-680b775fb37a463-d02
|
||||
(cons tmp-680b775fb37a463-d03 tmp-680b775fb37a463-d04)))
|
||||
(map (lambda (tmp-680b775fb37a463-ce2
|
||||
tmp-680b775fb37a463-ce1
|
||||
tmp-680b775fb37a463-ce0)
|
||||
(cons tmp-680b775fb37a463-ce0
|
||||
(cons tmp-680b775fb37a463-ce1 tmp-680b775fb37a463-ce2)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -2497,8 +2498,7 @@
|
|||
(let ((key type))
|
||||
(cond ((memv key '(lexical)) (values 'lexical value))
|
||||
((memv key '(macro)) (values 'macro value))
|
||||
((memv key '(syntax-parameter))
|
||||
(values 'syntax-parameter (car value)))
|
||||
((memv key '(syntax-parameter)) (values 'syntax-parameter value))
|
||||
((memv key '(syntax)) (values 'pattern-variable value))
|
||||
((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
|
||||
((memv key '(global))
|
||||
|
|
@ -2850,9 +2850,11 @@
|
|||
#f
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
(map (lambda (tmp-680b775fb37a463
|
||||
tmp-680b775fb37a463-114f
|
||||
tmp-680b775fb37a463-114e)
|
||||
(list (cons tmp-680b775fb37a463-114e tmp-680b775fb37a463-114f)
|
||||
tmp-680b775fb37a463))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2867,11 +2869,9 @@
|
|||
dots
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-118b
|
||||
tmp-680b775fb37a463-118a
|
||||
tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-118a)
|
||||
tmp-680b775fb37a463-118b))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2887,11 +2887,9 @@
|
|||
dots
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-11aa
|
||||
tmp-680b775fb37a463-11a9
|
||||
tmp-680b775fb37a463-11a8)
|
||||
(list (cons tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a9)
|
||||
tmp-680b775fb37a463-11aa))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -3039,8 +3037,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463)
|
||||
(list "value" tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-11f3)
|
||||
(list "value" tmp-680b775fb37a463-11f3))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3063,8 +3061,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463-121a)
|
||||
(list "value" tmp-680b775fb37a463-121a))
|
||||
(map (lambda (tmp-680b775fb37a463-11f8)
|
||||
(list "value" tmp-680b775fb37a463-11f8))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3098,7 +3096,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-120e)
|
||||
(list "value" tmp-680b775fb37a463-120e))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3208,8 +3207,8 @@
|
|||
(let ((tmp-1 ls))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-127e)
|
||||
(cons "vector" t-680b775fb37a463-127e))
|
||||
(apply (lambda (t-680b775fb37a463-125c)
|
||||
(cons "vector" t-680b775fb37a463-125c))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3219,8 +3218,7 @@
|
|||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (y)
|
||||
(k (map (lambda (tmp-680b775fb37a463-128a)
|
||||
(list "quote" tmp-680b775fb37a463-128a))
|
||||
(k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
|
||||
y)))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
|
||||
|
|
@ -3245,9 +3243,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12a8)
|
||||
(apply (lambda (t-680b775fb37a463)
|
||||
(cons (make-syntax 'list '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12a8))
|
||||
t-680b775fb37a463))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3263,10 +3261,10 @@
|
|||
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12bc t-680b775fb37a463-12bb)
|
||||
(apply (lambda (t-680b775fb37a463-129a t-680b775fb37a463)
|
||||
(list (make-syntax 'cons '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12bc
|
||||
t-680b775fb37a463-12bb))
|
||||
t-680b775fb37a463-129a
|
||||
t-680b775fb37a463))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3279,9 +3277,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12c8)
|
||||
(apply (lambda (t-680b775fb37a463-12a6)
|
||||
(cons (make-syntax 'append '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12c8))
|
||||
t-680b775fb37a463-12a6))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3294,9 +3292,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12d4)
|
||||
(apply (lambda (t-680b775fb37a463-12b2)
|
||||
(cons (make-syntax 'vector '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12d4))
|
||||
t-680b775fb37a463-12b2))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3307,9 +3305,9 @@
|
|||
(if tmp-1
|
||||
(apply (lambda (x)
|
||||
(let ((tmp (emit x)))
|
||||
(let ((t-680b775fb37a463-12e0 tmp))
|
||||
(let ((t-680b775fb37a463-12be tmp))
|
||||
(list (make-syntax 'list->vector '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12e0))))
|
||||
t-680b775fb37a463-12be))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
|
||||
(if tmp-1
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; -*-scheme-*-
|
||||
;;;;
|
||||
;;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -292,29 +292,7 @@
|
|||
(define session-id
|
||||
(let ((v (module-variable (current-module) 'syntax-session-id)))
|
||||
(lambda ()
|
||||
((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))))))))))
|
||||
|
||||
((variable-ref v))))))
|
||||
|
||||
(define (decorate-source e s)
|
||||
(if (and s (supports-source-properties? e))
|
||||
|
|
@ -513,11 +491,10 @@
|
|||
;; wrap : id --> label
|
||||
;; env : label --> <element>
|
||||
|
||||
;; environments are represented in two parts: a lexical part and a global
|
||||
;; part. The lexical part is a simple list of associations from labels
|
||||
;; to bindings. The global part is implemented by
|
||||
;; {put,get}-global-definition-hook and associates symbols with
|
||||
;; bindings.
|
||||
;; environments are represented in two parts: a lexical part and a
|
||||
;; global part. The lexical part is a simple list of associations
|
||||
;; from labels to bindings. The global part is implemented by
|
||||
;; Guile's module system and associates symbols with bindings.
|
||||
|
||||
;; global (assumed global variable) and displaced-lexical (see below)
|
||||
;; do not show up in any environment; instead, they are fabricated by
|
||||
|
|
@ -528,7 +505,7 @@
|
|||
;; identifier bindings include a type and a value
|
||||
|
||||
;; <binding> ::= (macro . <procedure>) macros
|
||||
;; (syntax-parameter . (<procedure>)) syntax parameters
|
||||
;; (syntax-parameter . <procedure>) syntax parameters
|
||||
;; (core . <procedure>) core forms
|
||||
;; (module-ref . <procedure>) @ or @@
|
||||
;; (begin) begin
|
||||
|
|
@ -610,7 +587,9 @@
|
|||
|
||||
(define global-extend
|
||||
(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,
|
||||
|
|
@ -892,27 +871,75 @@
|
|||
results)))))))
|
||||
(scan (wrap-subst w) '())))
|
||||
|
||||
;; Returns three values: binding type, binding value, the module (for
|
||||
;; resolving toplevel vars).
|
||||
;; Returns three values: binding type, binding value, and the module
|
||||
;; (for resolving toplevel vars).
|
||||
(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)
|
||||
(let ((b (resolve-syntax-parameters
|
||||
(or (get-global-definition-hook var mod)
|
||||
(make-binding 'global)))))
|
||||
(if (eq? (binding-type b) 'global)
|
||||
(values 'global var mod)
|
||||
(values (binding-type b) (binding-value b) mod))))
|
||||
(when (and (not mod) (current-module))
|
||||
(warn "module system is booted, we should have a module" var))
|
||||
(let ((v (and (not (equal? mod '(primitive)))
|
||||
(module-variable (if mod
|
||||
(resolve-module (cdr 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)
|
||||
(let ((b (resolve-syntax-parameters
|
||||
(or (assq-ref r label)
|
||||
(make-binding 'displaced-lexical)))))
|
||||
(values (binding-type b) (binding-value b) mod)))
|
||||
(let ((b (assq-ref r label)))
|
||||
(if b
|
||||
(let ((type (binding-type b))
|
||||
(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)))
|
||||
(cond
|
||||
((syntax-object? n)
|
||||
|
|
@ -1245,13 +1272,12 @@
|
|||
(build-primcall
|
||||
no-source
|
||||
'make-syntax-transformer
|
||||
(if (eq? type 'define-syntax-parameter-form)
|
||||
(list (build-data no-source name)
|
||||
(build-data no-source 'syntax-parameter)
|
||||
(build-primcall no-source 'list (list e)))
|
||||
(list (build-data no-source name)
|
||||
(build-data no-source 'macro)
|
||||
e))))))
|
||||
(list (build-data no-source name)
|
||||
(build-data no-source
|
||||
(if (eq? type 'define-syntax-parameter-form)
|
||||
'syntax-parameter
|
||||
'macro))
|
||||
e)))))
|
||||
|
||||
(define parse-when-list
|
||||
(lambda (e when-list)
|
||||
|
|
@ -1641,7 +1667,7 @@
|
|||
(cdr r)))
|
||||
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
|
||||
((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))
|
||||
(label (gen-label))
|
||||
(trans-r (macros-only-env er)))
|
||||
|
|
@ -1650,9 +1676,9 @@
|
|||
(list label)
|
||||
(list (make-binding
|
||||
'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)))
|
||||
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
|
||||
((begin-form)
|
||||
|
|
@ -2053,14 +2079,14 @@
|
|||
(let ((trans-r (macros-only-env r)))
|
||||
(map (lambda (x)
|
||||
(make-binding
|
||||
'macro
|
||||
'syntax-parameter
|
||||
(eval-local-transformer (expand x trans-r w mod) mod)))
|
||||
#'(val ...)))))
|
||||
(expand-body #'(e1 e2 ...)
|
||||
(source-wrap e w s mod)
|
||||
(extend-env names bindings r)
|
||||
w
|
||||
mod)))
|
||||
(source-wrap e w s mod)
|
||||
(extend-env names bindings r)
|
||||
w
|
||||
mod)))
|
||||
(_ (syntax-violation 'syntax-parameterize "bad syntax"
|
||||
(source-wrap e w s mod))))))
|
||||
|
||||
|
|
@ -2799,7 +2825,7 @@
|
|||
(case type
|
||||
((lexical) (values 'lexical value))
|
||||
((macro) (values 'macro value))
|
||||
((syntax-parameter) (values 'syntax-parameter (car value)))
|
||||
((syntax-parameter) (values 'syntax-parameter value))
|
||||
((syntax) (values 'pattern-variable value))
|
||||
((displaced-lexical) (values 'displaced-lexical #f))
|
||||
((global)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue