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.

2 files changed, 196 insertions, 172 deletions

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index ed967a613..6ee86210d 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 ffe37cffc..a51e99d9c 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)