add #:resolve-syntax-parameters? kwarg to syntax-local-binding

* doc/ref/api-macros.texi (Syntax Transformer Helpers): Document.

* module/ice-9/psyntax.scm (syntax-local-binding): Add
  #:resolve-syntax-parameters? kwarg.  Fixes bug 10991.
* module/ice-9/psyntax-pp.scm: Regenerate.

* test-suite/tests/syncase.test ("syntax-local-binding"): Add test.

diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 347d025..b08c103 100644 (file)
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011, 2012
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011, 2012, 2013
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -725,7 +725,7 @@ Return the name of the module whose source contains the identifier
 @var{id}.
 @end deffn
 
-@deffn {Scheme Procedure} syntax-local-binding id
+@deffn {Scheme Procedure} syntax-local-binding id [#:resolve-syntax-parameters?=#t]
 Resolve the identifer @var{id}, a syntax object, within the current
 lexical environment, and return two values, the binding type and a
 binding value.  The binding type is a symbol, which may be one of the
@@ -738,6 +738,12 @@ of @code{eq?}) identifying this binding.
 @item macro
 A syntax transformer, either local or global.  The value is the
 transformer procedure.
+@item syntax-parameter
+A syntax parameter (@pxref{Syntax Parameters}).  By default,
+@code{syntax-local-binding} will resolve syntax parameters, so that this
+value will not be returned.  Pass @code{#:resolve-syntax-parameters? #f}
+to indicate that you are interested in syntax parameters.  The value is
+the default transformer procedure, as in @code{macro}.
 @item pattern-variable
 A pattern variable, bound via syntax-case.  The value is an opaque
 object, internal to the expander.

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index e330423..ada9307 100644 (file)
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2345,7 +2345,9 @@
              (syntax-violation 'syntax-module "invalid argument" x)))
          (cdr (syntax-object-module id))))
      (syntax-local-binding
-       (lambda (id)
+       (lambda* (id
+                 #:key
+                 (resolve-syntax-parameters? #t #:resolve-syntax-parameters?))
          (let ((x id))
            (if (not (nonsymbol-id? x))
              (syntax-violation 'syntax-local-binding "invalid argument" x)))
@@ -2365,11 +2367,13 @@
                      (strip-anti-mark (syntax-object-wrap id))
                      r
                      (syntax-object-module id)
-                     #t))
+                     resolve-syntax-parameters?))
                  (lambda (type value mod)
                    (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)) (values 'pattern-variable value))
                            ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
                            ((memv key '(global)) (values 'global (cons value (cdr mod))))

diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 79f2fd4..90c76d5 100644 (file)
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2648,7 +2648,7 @@
         (arg-check nonsymbol-id? id 'syntax-module)
         (cdr (syntax-object-module id)))
 
-      (define (syntax-local-binding id)
+      (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
         (arg-check nonsymbol-id? id 'syntax-local-binding)
         (with-transformer-environment
          (lambda (e r w s rib mod)
@@ -2665,13 +2665,12 @@
                                 (strip-anti-mark (syntax-object-wrap id))
                                 r
                                 (syntax-object-module id)
-                                ;; FIXME: come up with a better policy for
-                                ;; resolve-syntax-parameters
-                                #t))
+                                resolve-syntax-parameters?))
              (lambda (type value mod)
                (case type
                  ((lexical) (values 'lexical value))
                  ((macro) (values 'macro value))
+                 ((syntax-parameter) (values 'syntax-parameter (car value)))
                  ((syntax) (values 'pattern-variable value))
                  ((displaced-lexical) (values 'displaced-lexical #f))
                  ((global) (values 'global (cons value (cdr mod))))

diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 0e81f65..3b44ba0 100644 (file)
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -1,6 +1,6 @@
 ;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
 ;;;;
-;;;;   Copyright (C) 2001, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013 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
@@ -239,3 +239,28 @@
                  ((odd? x) (not (even? x)))))
              (even? 10))
           (current-module))))
+
+(use-modules (system syntax))
+
+(with-test-prefix "syntax-local-binding"
+  (define-syntax syntax-type
+    (lambda (x)
+      (syntax-case x ()
+        ((_ id resolve?)
+         (call-with-values
+             (lambda ()
+               (syntax-local-binding
+                #'id
+                #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
+           (lambda (type value)
+             (with-syntax ((type (datum->syntax #'id type)))
+               #''type)))))))
+
+  (define-syntax-parameter foo
+    (syntax-rules ()))
+
+  (pass-if "syntax-parameters (resolved)"
+    (equal? (syntax-type foo #t) 'macro))
+
+  (pass-if "syntax-parameters (unresolved)"
+    (equal? (syntax-type foo #f) 'syntax-parameter)))