[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Fix race when expanding syntax-parameterize and d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Fix race when expanding syntax-parameterize and define-syntax-parameter |
|
Date: |
Fri, 22 Feb 2019 10:28:23 -0500 (EST) |
wingo pushed a commit to branch stable-2.2
in repository guile.
commit 2dccec9f553776656d9378e2315ad32d2e55286b
Author: Andy Wingo <address@hidden>
Date: Fri Feb 22 15:25:21 2019 +0100
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.
---
module/ice-9/psyntax-pp.scm | 210 ++++++++++++++++++++++----------------------
module/ice-9/psyntax.scm | 158 +++++++++++++++++++--------------
2 files changed, 196 insertions(+), 172 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index ed967a6..6ee8621 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -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
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index ffe37cf..a51e99d 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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)