add syntax-local-binding

* module/ice-9/boot-9.scm (syntax-local-binding): New binding.

* module/ice-9/psyntax.scm: Locally define a fluid that holds the
  "transformer environment".  with-transformer-environment calls a
  procedure with the transformer environment, or raises an error if
  called outside the extent of a transformer.  Bind
  transformer-environment in expand-macro.
  (resolve-identifier): Backport this helper from master.
  (syntax-local-binding): New procedure to return binding information of
  a bound identifier (a lexical, macro, a pattern variable, a displaced
  lexical, a global, or some other form).

* module/ice-9/psyntax-pp.scm: Regenerate.

* doc/ref/api-macros.texi (Syntax Transformer Helpers): Add docs for
  syntax-local-binding, and syntax-source, and move some other
  descriptions to this new section.

doc/ref/api-macros.texi

@@ -38,9 +38,10 @@ languages}, or EDSLs.}.
 * Defining Macros::             Binding macros, globally and locally.
 * Syntax Rules::                Pattern-driven macros.
 * Syntax Case::                 Procedural, hygienic macros.
+* Syntax Transformer Helpers::  Helpers for use in procedural macros.
 * Defmacros::                   Lisp-style macros.
 * Identifier Macros::           Identifier macros.
-* Syntax Parameters::           Syntax Parameters
+* Syntax Parameters::           Syntax Parameters.
 * Eval When::                   Affecting the expand-time environment.
 * Internal Macros::             Macros as first-class values.
 @end menu
@@ -671,28 +672,101 @@ source file, one may write:
           (newline))))))
 @end example
 
-Finally, we should mention the following helper procedures defined by the core
+Readers interested in further information on @code{syntax-case} macros should
-of @code{syntax-case}:
+see R. Kent Dybvig's excellent @cite{The Scheme Programming Language}, either
+edition 3 or 4, in the chapter on syntax. Dybvig was the primary author of the
+@code{syntax-case} system. The book itself is available online at
+@uref{http://scheme.com/tspl4/}.
+
+@node Syntax Transformer Helpers
+@subsection Syntax Transformer Helpers
+
+As noted in the previous section, Guile's syntax expander operates on
+syntax objects.  Procedural macros consume and produce syntax objects.
+This section describes some of the auxiliary helpers that procedural
+macros can use to compare, generate, and query objects of this data
+type.
 
 @deffn {Scheme Procedure} bound-identifier=? a b
-Returns @code{#t} iff the syntax objects @var{a} and @var{b} refer to the same
+Return @code{#t} iff the syntax objects @var{a} and @var{b} refer to the
-lexically-bound identifier.
+same lexically-bound identifier.
 @end deffn
 
 @deffn {Scheme Procedure} free-identifier=? a b
-Returns @code{#t} iff the syntax objects @var{a} and @var{b} refer to the same
+Return @code{#t} iff the syntax objects @var{a} and @var{b} refer to the
-free identifier.
+same free identifier.
 @end deffn
 
 @deffn {Scheme Procedure} generate-temporaries ls
 Return a list of temporary identifiers as long as @var{ls} is long.
 @end deffn
 
-Readers interested in further information on @code{syntax-case} macros should
+@deffn {Scheme Procedure} syntax-source x
-see R. Kent Dybvig's excellent @cite{The Scheme Programming Language}, either
+Return the source properties that correspond to the syntax object
-edition 3 or 4, in the chapter on syntax. Dybvig was the primary author of the
+@var{x}.  @xref{Source Properties}, for more information.
-@code{syntax-case} system. The book itself is available online at
+@end deffn
-@uref{http://scheme.com/tspl4/}.
+
+@deffn {Scheme Procedure} syntax-local-binding id
+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
+following:
+
+@table @code
+@item lexical
+A lexically-bound variable.  The value is a unique token (in the sense
+of @code{eq?}) identifying this binding.
+@item macro
+A syntax transformer, either local or global.  The value is the
+transformer procedure.
+@item pattern-variable
+A pattern variable, bound via syntax-case.  The value is an opaque
+object, internal to the expander.
+@item displaced-lexical
+A lexical variable that has gone out of scope.  This can happen if a
+badly-written procedural macro saves a syntax object, then attempts to
+introduce it in a context in which it is unbound.  The value is
+@code{#f}.
+@item global
+A global binding.  The value is a pair, whose head is the symbol, and
+whose tail is the name of the module in which to resolve the symbol.
+@item other
+Some other binding, like @code{lambda} or other core bindings.  The
+value is @code{#f}.
+@end table
+
+This is a very low-level procedure, with limited uses.  One case in
+which it is useful is to build abstractions that associate auxiliary
+information with macros:
+
+@example
+(define aux-property (make-object-property))
+(define-syntax-rule (with-aux aux value)
+  (let ((trans value))
+    (set! (aux-property trans) aux)
+    trans)))
+(define-syntax retrieve-aux
+  (lambda (x)
+    (syntax-case x ()
+      ((x id)
+       (call-with-values (lambda () (syntax-local-binding #'id))
+         (lambda (type val)
+           (with-syntax ((aux (datum->syntax #'here
+                                             (and (eq? type 'macro)
+                                                  (aux-property val)))))
+             #''aux)))))))
+(define-syntax foo
+  (with-aux 'bar
+    (syntax-rules () ((_) 'foo))))
+(foo)
+@result{} foo
+(retrieve-aux foo)
+@result{} bar
+@end example
+
+@code{syntax-local-binding} must be called within the dynamic extent of
+a syntax transformer; to call it otherwise will signal an error.
+@end deffn
 
 @node Defmacros
 @subsection Lisp-style Macro Definitions

module/ice-9/boot-9.scm

@@ -389,6 +389,7 @@ If there is no handler at all, Guile prints an error and then exits."
 (define generate-temporaries #f)
 (define bound-identifier=? #f)
 (define free-identifier=? #f)
+(define syntax-local-binding #f)
 
 ;; $sc-dispatch is an implementation detail of psyntax. It is used by
 ;; expanded macros, to dispatch an input against a set of patterns.

module/ice-9/psyntax.scm

@@ -786,6 +786,40 @@
                       id))))))
          (else (syntax-violation 'id-var-name "invalid id" id)))))
 
+    ;; Returns three values: binding type, binding value, the module (for
+    ;; resolving toplevel vars).
+    (define (resolve-identifier id w r mod)
+      (define (resolve-global var mod)
+        (let ((b (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))))
+      (define (resolve-lexical label mod)
+        (let ((b (or (assq-ref r label)
+                     (make-binding 'displaced-lexical))))
+          (values (binding-type b) (binding-value b) mod)))
+      (let ((n (id-var-name id w)))
+        (cond
+         ((symbol? n)
+          (resolve-global n (if (syntax-object? id)
+                                (syntax-object-module id)
+                                mod)))
+         ((string? n)
+          (resolve-lexical n (if (syntax-object? id)
+                                 (syntax-object-module id)
+                                 mod)))
+         (else
+          (error "unexpected id-var-name" id w n)))))
+
+    (define transformer-environment
+      (make-fluid
+       (lambda (k)
+         (error "called outside the dynamic extent of a syntax transformer"))))
+
+    (define (with-transformer-environment k)
+      ((fluid-ref transformer-environment) k))
+
     ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
     ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
 
@@ -1321,8 +1355,10 @@
                    (syntax-violation #f "encountered raw symbol in macro output"
                                      (source-wrap e w (wrap-subst w) mod) x))
                   (else (decorate-source x s)))))
-        (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
+        (with-fluids ((transformer-environment
-                              (new-mark))))
+                       (lambda (k) (k e r w s rib mod))))
+          (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
+                                (new-mark)))))
 
     (define expand-body
       ;; In processing the forms of the body, we create a new, empty wrap.
@@ -2435,6 +2471,33 @@
     (set! syntax-source
           (lambda (x) (source-annotation x)))
 
+    (set! syntax-local-binding
+          (lambda (id)
+            (arg-check nonsymbol-id? id 'syntax-local-value)
+            (with-transformer-environment
+             (lambda (e r w s rib mod)
+               (define (strip-anti-mark w)
+                 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+                   (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+                       ;; output is from original text
+                       (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+                       ;; output introduced by macro
+                       (make-wrap ms (if rib (cons rib s) s)))))
+               (call-with-values (lambda ()
+                                   (resolve-identifier
+                                    (syntax-object-expression id)
+                                    (strip-anti-mark (syntax-object-wrap id))
+                                    r
+                                    (syntax-object-module id)))
+                 (lambda (type value mod)
+                   (case type
+                     ((lexical) (values 'lexical value))
+                     ((macro) (values 'macro value))
+                     ((syntax) (values 'pattern-variable value))
+                     ((displaced-lexical) (values 'displaced-lexical #f))
+                     ((global) (values 'global (cons value mod)))
+                     (else (values 'other #f)))))))))
+
     (set! generate-temporaries
           (lambda (ls)
             (arg-check list? ls 'generate-temporaries)