[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Fix race when expanding syntax-parameterize and d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/02: Fix race when expanding syntax-parameterize and define-syntax-parameter |
|
Date: |
Fri, 22 Feb 2019 09:13:49 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 61a8c9300daeb730fe5094f889bf13241942be84
Author: Andy Wingo <address@hidden>
Date: Fri Feb 22 15:01:29 2019 +0100
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.
---
libguile/macros.c | 6 +-
module/ice-9/psyntax-pp.scm | 206 ++++++++++++++++++++++----------------------
module/ice-9/psyntax.scm | 158 +++++++++++++++++++--------------
3 files changed, 199 insertions(+), 171 deletions(-)
diff --git a/libguile/macros.c b/libguile/macros.c
index 70373e8..e26ed65 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -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;
}
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 532e80f..151bf8e 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -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
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index adc6997..0cad977 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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)