mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Fix race when expanding syntax-parameterize and define-syntax-parameter
* libguile/macros.c (scm_i_make_primitive_macro): Give primitive macros a primitive-macro macro-type. * 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
c537f938d1
commit
61a8c9300d
3 changed files with 199 additions and 171 deletions
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright 1995-1998,2000-2003,2006,2008-2012,2018
|
||||
/* Copyright 1995-1998,2000-2003,2006,2008-2012,2018-2019
|
||||
Free Software Foundation, Inc.
|
||||
|
||||
This file is part of Guile.
|
||||
|
|
@ -64,6 +64,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
SCM_SYMBOL (sym_primitive_macro, "primitive-macro");
|
||||
|
||||
/* Return a mmacro that is known to be one of guile's built in macros. */
|
||||
SCM
|
||||
scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn)
|
||||
|
|
@ -71,7 +73,7 @@ scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn)
|
|||
SCM z = scm_words (scm_tc16_macro, 5);
|
||||
SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn);
|
||||
SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_utf8_symbol (name));
|
||||
SCM_SET_SMOB_OBJECT_N (z, 3, SCM_BOOL_F);
|
||||
SCM_SET_SMOB_OBJECT_N (z, 3, sym_primitive_macro);
|
||||
SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F);
|
||||
return z;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -116,26 +116,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))
|
||||
|
|
@ -273,7 +253,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? x) (symbol? (syntax-expression x)))))
|
||||
(id? (lambda (x)
|
||||
|
|
@ -432,23 +416,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? n)
|
||||
(if (not (eq? n id))
|
||||
|
|
@ -692,11 +690,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 '(()))))
|
||||
|
|
@ -976,11 +976,11 @@
|
|||
(source-wrap e w (cdr w) mod)
|
||||
x))
|
||||
(else (decorate-source x s))))))
|
||||
(let* ((t-680b775fb37a463-7da transformer-environment)
|
||||
(t-680b775fb37a463-7db (lambda (k) (k e r w s rib mod))))
|
||||
(let* ((t-680b775fb37a463-7b8 transformer-environment)
|
||||
(t-680b775fb37a463-7b9 (lambda (k) (k e r w s rib mod))))
|
||||
(with-fluid*
|
||||
t-680b775fb37a463-7da
|
||||
t-680b775fb37a463-7db
|
||||
t-680b775fb37a463-7b8
|
||||
t-680b775fb37a463-7b9
|
||||
(lambda ()
|
||||
(rebuild-macro-output
|
||||
(p (source-wrap e (anti-mark w) s mod))
|
||||
|
|
@ -1038,7 +1038,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))
|
||||
|
|
@ -1513,11 +1513,11 @@
|
|||
s
|
||||
mod
|
||||
get-formals
|
||||
(map (lambda (tmp-680b775fb37a463-acb
|
||||
tmp-680b775fb37a463-aca
|
||||
tmp-680b775fb37a463-ac9)
|
||||
(cons tmp-680b775fb37a463-ac9
|
||||
(cons tmp-680b775fb37a463-aca tmp-680b775fb37a463-acb)))
|
||||
(map (lambda (tmp-680b775fb37a463-aa9
|
||||
tmp-680b775fb37a463-aa8
|
||||
tmp-680b775fb37a463-aa7)
|
||||
(cons tmp-680b775fb37a463-aa7
|
||||
(cons tmp-680b775fb37a463-aa8 tmp-680b775fb37a463-aa9)))
|
||||
e2*
|
||||
e1*
|
||||
args*)))
|
||||
|
|
@ -1590,7 +1590,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)
|
||||
|
|
@ -1814,11 +1815,11 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-c98
|
||||
tmp-680b775fb37a463-c97
|
||||
tmp-680b775fb37a463-c96)
|
||||
(cons tmp-680b775fb37a463-c96
|
||||
(cons tmp-680b775fb37a463-c97 tmp-680b775fb37a463-c98)))
|
||||
(map (lambda (tmp-680b775fb37a463-c76
|
||||
tmp-680b775fb37a463-c75
|
||||
tmp-680b775fb37a463-c74)
|
||||
(cons tmp-680b775fb37a463-c74
|
||||
(cons tmp-680b775fb37a463-c75 tmp-680b775fb37a463-c76)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1830,11 +1831,11 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-cae
|
||||
tmp-680b775fb37a463-cad
|
||||
tmp-680b775fb37a463-cac)
|
||||
(cons tmp-680b775fb37a463-cac
|
||||
(cons tmp-680b775fb37a463-cad tmp-680b775fb37a463-cae)))
|
||||
(map (lambda (tmp-680b775fb37a463-c8c
|
||||
tmp-680b775fb37a463-c8b
|
||||
tmp-680b775fb37a463-c8a)
|
||||
(cons tmp-680b775fb37a463-c8a
|
||||
(cons tmp-680b775fb37a463-c8b tmp-680b775fb37a463-c8c)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1857,11 +1858,11 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(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)))
|
||||
|
|
@ -1873,11 +1874,11 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-ce4
|
||||
tmp-680b775fb37a463-ce3
|
||||
tmp-680b775fb37a463-ce2)
|
||||
(cons tmp-680b775fb37a463-ce2
|
||||
(cons tmp-680b775fb37a463-ce3 tmp-680b775fb37a463-ce4)))
|
||||
(map (lambda (tmp-680b775fb37a463-cc2
|
||||
tmp-680b775fb37a463-cc1
|
||||
tmp-680b775fb37a463-cc0)
|
||||
(cons tmp-680b775fb37a463-cc0
|
||||
(cons tmp-680b775fb37a463-cc1 tmp-680b775fb37a463-cc2)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -2452,8 +2453,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))
|
||||
|
|
@ -2802,9 +2802,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-112f
|
||||
tmp-680b775fb37a463-112e)
|
||||
(list (cons tmp-680b775fb37a463-112e tmp-680b775fb37a463-112f)
|
||||
tmp-680b775fb37a463))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2819,11 +2821,9 @@
|
|||
dots
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-116b
|
||||
tmp-680b775fb37a463-116a
|
||||
tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-116a)
|
||||
tmp-680b775fb37a463-116b))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2839,9 +2839,9 @@
|
|||
dots
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-118a))
|
||||
tmp-680b775fb37a463-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2989,8 +2989,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463-11f5)
|
||||
(list "value" tmp-680b775fb37a463-11f5))
|
||||
(map (lambda (tmp-680b775fb37a463-11d3)
|
||||
(list "value" tmp-680b775fb37a463-11d3))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3013,8 +3013,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463-11fa)
|
||||
(list "value" tmp-680b775fb37a463-11fa))
|
||||
(map (lambda (tmp-680b775fb37a463-11d8)
|
||||
(list "value" tmp-680b775fb37a463-11d8))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3048,7 +3048,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-11ee)
|
||||
(list "value" tmp-680b775fb37a463-11ee))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3067,8 +3068,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463)
|
||||
(list "value" tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-11f3)
|
||||
(list "value" tmp-680b775fb37a463-11f3))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3158,8 +3159,8 @@
|
|||
(let ((tmp-1 ls))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-125e)
|
||||
(cons "vector" t-680b775fb37a463-125e))
|
||||
(apply (lambda (t-680b775fb37a463-123c)
|
||||
(cons "vector" t-680b775fb37a463-123c))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3169,8 +3170,7 @@
|
|||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (y)
|
||||
(k (map (lambda (tmp-680b775fb37a463-126a)
|
||||
(list "quote" tmp-680b775fb37a463-126a))
|
||||
(k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
|
||||
y)))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
|
||||
|
|
@ -3213,10 +3213,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-129c t-680b775fb37a463-129b)
|
||||
(apply (lambda (t-680b775fb37a463-127a t-680b775fb37a463)
|
||||
(list (make-syntax 'cons '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-129c
|
||||
t-680b775fb37a463-129b))
|
||||
t-680b775fb37a463-127a
|
||||
t-680b775fb37a463))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3229,9 +3229,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 'append '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12a8))
|
||||
t-680b775fb37a463))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3244,9 +3244,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12b4)
|
||||
(apply (lambda (t-680b775fb37a463)
|
||||
(cons (make-syntax 'vector '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12b4))
|
||||
t-680b775fb37a463))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3257,9 +3257,9 @@
|
|||
(if tmp-1
|
||||
(apply (lambda (x)
|
||||
(let ((tmp (emit x)))
|
||||
(let ((t-680b775fb37a463-12c0 tmp))
|
||||
(let ((t-680b775fb37a463-129e tmp))
|
||||
(list (make-syntax 'list->vector '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12c0))))
|
||||
t-680b775fb37a463-129e))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
|
||||
(if tmp-1
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; -*-scheme-*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2018
|
||||
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2019
|
||||
;;;; Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
|
|
@ -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))
|
||||
|
|
@ -492,11 +470,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
|
||||
|
|
@ -507,7 +484,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
|
||||
|
|
@ -589,7 +566,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,
|
||||
|
|
@ -871,27 +850,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? n)
|
||||
|
|
@ -1224,13 +1251,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)
|
||||
|
|
@ -1620,7 +1646,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)))
|
||||
|
|
@ -1629,9 +1655,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)
|
||||
|
|
@ -2032,14 +2058,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))))))
|
||||
|
||||
|
|
@ -2778,7 +2804,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