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

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

Browse source 
* 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 2019-02-22 15:01:29 +01:00
parent c537f938d1
commit 61a8c9300d
3 changed files with 199 additions and 171 deletions
Download patch file Download diff file Expand all files Collapse all files

6
libguile/macros.c
View file

@ -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. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -64,6 +64,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
return 1; return 1;
} }
SCM_SYMBOL (sym_primitive_macro, "primitive-macro");
/* Return a mmacro that is known to be one of guile's built in macros. */ /* Return a mmacro that is known to be one of guile's built in macros. */
SCM SCM
scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn) 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 z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn); 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, 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); SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F);
return z; return z;
} }

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

@ -116,26 +116,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))
@ -273,7 +253,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) (and (syntax? x) (symbol? (syntax-expression x))))) (lambda (x) (and (syntax? x) (symbol? (syntax-expression x)))))
(id? (lambda (x) (id? (lambda (x)
@ -432,23 +416,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? n) (cond ((syntax? n)
(if (not (eq? n id)) (if (not (eq? n id))
@ -692,11 +690,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 #f 'syntax-parameter) (build-data
(build-primcall #f 'list (list e))) #f
(list (build-data #f name) (build-data #f 'macro) e)))))) (if (eq? type 'define-syntax-parameter-form)
'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 '(()))))
@ -976,11 +976,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-7da transformer-environment) (let* ((t-680b775fb37a463-7b8 transformer-environment)
(t-680b775fb37a463-7db (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-7b9 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-7da t-680b775fb37a463-7b8
t-680b775fb37a463-7db t-680b775fb37a463-7b9
(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))
@ -1038,7 +1038,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))
@ -1513,11 +1513,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-acb (map (lambda (tmp-680b775fb37a463-aa9
tmp-680b775fb37a463-aca tmp-680b775fb37a463-aa8
tmp-680b775fb37a463-ac9) tmp-680b775fb37a463-aa7)
(cons tmp-680b775fb37a463-ac9 (cons tmp-680b775fb37a463-aa7
(cons tmp-680b775fb37a463-aca tmp-680b775fb37a463-acb))) (cons tmp-680b775fb37a463-aa8 tmp-680b775fb37a463-aa9)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1590,7 +1590,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)
@ -1814,11 +1815,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-c98 (map (lambda (tmp-680b775fb37a463-c76
tmp-680b775fb37a463-c97 tmp-680b775fb37a463-c75
tmp-680b775fb37a463-c96) tmp-680b775fb37a463-c74)
(cons tmp-680b775fb37a463-c96 (cons tmp-680b775fb37a463-c74
(cons tmp-680b775fb37a463-c97 tmp-680b775fb37a463-c98))) (cons tmp-680b775fb37a463-c75 tmp-680b775fb37a463-c76)))
e2 e2
e1 e1
args))) args)))
@ -1830,11 +1831,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-cae (map (lambda (tmp-680b775fb37a463-c8c
tmp-680b775fb37a463-cad tmp-680b775fb37a463-c8b
tmp-680b775fb37a463-cac) tmp-680b775fb37a463-c8a)
(cons tmp-680b775fb37a463-cac (cons tmp-680b775fb37a463-c8a
(cons tmp-680b775fb37a463-cad tmp-680b775fb37a463-cae))) (cons tmp-680b775fb37a463-c8b tmp-680b775fb37a463-c8c)))
e2 e2
e1 e1
args))) args)))
@ -1857,11 +1858,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(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)))
@ -1873,11 +1874,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-ce4 (map (lambda (tmp-680b775fb37a463-cc2
tmp-680b775fb37a463-ce3 tmp-680b775fb37a463-cc1
tmp-680b775fb37a463-ce2) tmp-680b775fb37a463-cc0)
(cons tmp-680b775fb37a463-ce2 (cons tmp-680b775fb37a463-cc0
(cons tmp-680b775fb37a463-ce3 tmp-680b775fb37a463-ce4))) (cons tmp-680b775fb37a463-cc1 tmp-680b775fb37a463-cc2)))
e2 e2
e1 e1
args))) args)))
@ -2452,8 +2453,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))
@ -2802,9 +2802,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-112f
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-112e)
(list (cons tmp-680b775fb37a463-112e tmp-680b775fb37a463-112f)
tmp-680b775fb37a463))
template template
pattern pattern
keyword))) keyword)))
@ -2819,11 +2821,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-116b (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-116a (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-116a)
tmp-680b775fb37a463-116b))
template template
pattern pattern
keyword))) keyword)))
@ -2839,9 +2839,9 @@
dots dots
k k
(list docstring) (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) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-118a)) tmp-680b775fb37a463-2))
template template
pattern pattern
keyword))) keyword)))
@ -2989,8 +2989,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-11f5) (map (lambda (tmp-680b775fb37a463-11d3)
(list "value" tmp-680b775fb37a463-11f5)) (list "value" tmp-680b775fb37a463-11d3))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3013,8 +3013,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-11fa) (map (lambda (tmp-680b775fb37a463-11d8)
(list "value" tmp-680b775fb37a463-11fa)) (list "value" tmp-680b775fb37a463-11d8))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3048,7 +3048,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-11ee)
(list "value" tmp-680b775fb37a463-11ee))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3067,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-11f3)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-11f3))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3158,8 +3159,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-125e) (apply (lambda (t-680b775fb37a463-123c)
(cons "vector" t-680b775fb37a463-125e)) (cons "vector" t-680b775fb37a463-123c))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3169,8 +3170,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-126a) (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
(list "quote" tmp-680b775fb37a463-126a))
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))))
@ -3213,10 +3213,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-129c t-680b775fb37a463-129b) (apply (lambda (t-680b775fb37a463-127a t-680b775fb37a463)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-129c t-680b775fb37a463-127a
t-680b775fb37a463-129b)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3229,9 +3229,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 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12a8)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3244,9 +3244,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-12b4) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12b4)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3257,9 +3257,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12c0 tmp)) (let ((t-680b775fb37a463-129e tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12c0)))) t-680b775fb37a463-129e))))
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

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

@ -1,6 +1,6 @@
;;;; -*-scheme-*- ;;;; -*-scheme-*-
;;;; ;;;;
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2018 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2019
;;;; Free Software Foundation, Inc. ;;;; 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
@ -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))
@ -492,11 +470,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
@ -507,7 +484,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
@ -589,7 +566,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,
@ -871,27 +850,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? n) ((syntax? n)
@ -1224,13 +1251,12 @@
(build-primcall (build-primcall
no-source no-source
'make-syntax-transformer 'make-syntax-transformer
(list (build-data no-source name)
(build-data no-source
(if (eq? type 'define-syntax-parameter-form) (if (eq? type 'define-syntax-parameter-form)
(list (build-data no-source name) 'syntax-parameter
(build-data no-source 'syntax-parameter) 'macro))
(build-primcall no-source 'list (list e))) e)))))
(list (build-data no-source name)
(build-data no-source 'macro)
e))))))
(define parse-when-list (define parse-when-list
(lambda (e when-list) (lambda (e when-list)
@ -1620,7 +1646,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)))
@ -1629,9 +1655,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)
@ -2032,7 +2058,7 @@
(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 ...)
@ -2778,7 +2804,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)