#|[
Author: Juergen Lorenz
ju (at) jugilo (dot) de

Copyright (c) 2013, Juergen Lorenz
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

Neither the name of the author nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission. 

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

This module provides simplyfied versions of some of the bindings
macros, restricting destructuring to nested list expressions, as well
as macros making the writing of low-level-macros easy.
]|# 

(module list-binding-helpers
  (export list-binding-helpers pattern? tree-ref pindex pmap pflatten quote-last)
  (import scheme (only chicken error))

;;; (list-ref* lst . ks)
;;; --------------------
;;; references elements of possibly deeply nested lists
;;; (for comparison purpose only)
(define (list-ref* lst . ks)
  (cond
    ((null? ks) lst)
    ((null? (cdr ks)) (list-ref lst (car ks)))
    (else (apply list-ref* (list-ref lst (car ks)) (cdr ks)))))

;;; (tree-ref k ...) or (tree-ref k ... '(l))
;;; -----------------    ----------------------
;;; (the latter for handling the rest parameter in nested pseudolists)
;;; references elements of possibly deeply nested pseudolists.
(define (tree-ref lst . ks) ; ok
  (cond
    ((null? ks) lst)
    ((null? (cdr ks)) ; flat pseudolist
     (let ((ks (car ks)))
       (if (pair? lst)
         (if (integer? ks)
           (if (zero? ks)
             (car lst)
             (tree-ref (cdr lst) (- ks 1)))
           ;; pair
           (if (zero? (car ks))
             lst
             (tree-ref (cdr lst) (list (- (car ks) 1)))))
         (if (and (pair? ks) (zero? (car ks)))
           lst
           (error 'tree-ref "match error")))))
    (else
     (apply tree-ref (tree-ref lst (car ks)) (cdr ks)))))

;;; (quote-last lst)
;;; ----------------
;;; quotes the last item of an index list in case it is itself a list.
;;; For example, (0 1 2) is untouched, but (0 1 (2)) is transformed to
;;; (0 1 '(2))
(define (quote-last lst)
  (let loop ((lst lst) (result '()))
    (if (null? (cdr lst))
      (reverse (cons (if (list? (car lst)) `',(car lst) (car lst)) result))
      (loop (cdr lst) (cons (car lst) result)))))

;;; (pattern? xpr)
;;; --------------
;;; checks, if xpr is a pattern, i.e. a nested lambda-list
(define (pattern? xpr)
  (or (symbol? xpr)
      (null? xpr)
      (and (pair? xpr)
           (not (null? (car xpr)))
           (pattern? (car xpr))
           (pattern? (cdr xpr)))))

;;; (pmap fn pat)
;;; -------------
;;; maps the pattern variables, i.e. the symbols, of a pattern with
;;; function fn to a nested list with the same structure as pat
(define (pmap fn pat)
  (cond
    ((null? pat) '())
    ((symbol? pat) (fn pat))
    ((pair? pat)
     (cons (pmap fn (car pat)) (pmap fn (cdr pat))))))

;;; (pflatten pat)
;;; --------------
;;; maps a pattern, pat, to a flat list of symbols
(define (pflatten pat)
  (cond
    ((null? pat) '())
    ((symbol? pat) (list pat))
    (else
      (append (pflatten (car pat))
              (pflatten (cdr pat))))))

;;; (pindex pat)
;;; ------------
;;; indexes the pattern variables of a pattern, pat, so that tree-ref
;;; can destructure a nested pseudolist by means of the generated
;;; indices.
;;; The index of each non-null leaf item is packaged in a singleton
;;; list. For example, (pindex '(a (b c)) produces the list ((0) (1 0)
;;; (1 1)) while (pindex '(a (b . c)) produces ((0) (1 0) (1 (1)))
(define (pindex pat)
  (let recur ((k 0) (pat pat))
    (cond
      ((null? pat) '())
      ((symbol? pat) (list (list (list k))))
      ((symbol? (car pat))
       (cons (list k) (recur (+ k 1) (cdr pat))))
      ((pair? (car pat))
       (append (map (lambda (x) (cons k x)) (recur 0 (car pat)))
               (recur (+ k 1) (cdr pat)))))))

(define (list-binding-helpers)
  '(pattern? pindex pmap pflatten tree-ref)) 

) ; list-binding-helpers

(module list-bindings
  (export list-bindings bind-define bind-set! bind bindable? bind-case
          bind/cc bind-let bind-let* define-syntax-rule define-macro
          let-macro letrec-macro tree-ref)
  (import scheme
          (only chicken condition-case error)
          (only extras format)
          (only list-binding-helpers tree-ref))
  (import-for-syntax (only list-binding-helpers pattern? pindex
                           tree-ref pmap pflatten quote-last))

#|[
Binding macros
==============

The old version of bind
;;; (bind pat tpl . body)
;;; --------------------------
;;; Common Lisp's destructuring bind
;;; binds pattern variables of pat to corresponding subexpression of
;;; tpl and evalueates body in this context
;;; (This is the old version)
(define-syntax bind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (if (< (length form) 4)
        (error 'bind "macro-code doesn't match pattern "
               '(_ pat lst xpr . xprs))
        (let ((pat (cadr form))
              (xpr (caddr form))
              (body (cdddr form)))
          (letrec (
            (pmap (lambda (pl)
                    (cond
                      ((pair? pl)
                       (cons (if (symbol? (car pl)) (car pl) (gensym)) (pmap (cdr pl))))
                      ((null? pl) pl)
                      ((symbol? pl) pl)
                      )))
            (listify (lambda (pl)
                       (cond
                         ((pair? pl)
                          (cons (car pl) (listify (cdr pl))))
                         ((null? pl) pl)
                         ((symbol? pl) (list pl)))))
            (flat? (lambda (pl)
                     (or (symbol? pl)
                         (null? pl)
                         (and (symbol? (car pl)) (flat? (cdr pl))))))
            (nested-lambda-list? (lambda (xpr)
                                   (or (symbol? xpr)
                                       (null? xpr)
                                       (and (pair? xpr)
                                            (nested-lambda-list? (car xpr))
                                            (nested-lambda-list? (cdr xpr))))))
            )
            (if (not (nested-lambda-list? pat))
              (error 'bind "not a nested lambda-list" pat)
              (if (flat? pat)
                (cond
                  ((pair? pat)
                   `(apply (lambda ,pat ,@body) ,xpr))
                  ((null? pat)
                   `(apply (lambda ,pat ,@body) ,xpr))
                  ((symbol? pat)
                   `((lambda (,pat) ,@body) ,xpr)))
                (let ((new-pat (pmap pat)))
                  (let ((lst `(bind ,new-pat ,xpr
                                (list ,@(listify new-pat)))))
                     `(bind ,(car pat) (car ,lst)
                       (bind ,(listify (cdr pat)) (cdr ,lst)
                         ,@body))))))))))))
]|# 

;;; (bindable? pat)
;;; ---------------
;;; returns a procedure, which checks, if subexpressions of its only
;;; agument, tpl, are bindable to the pattern variables of pat.
(define-syntax bindable?
  (syntax-rules ()
    ((_ ())
     (lambda (tpl) (null? tpl)))
    ((_ (a . b))
     (lambda (tpl)
       (and (pair? tpl)
            ((bindable? a) (car tpl))
            ((bindable? b) (cdr tpl)))))
    ((_ a) (lambda (tpl) #t))))


#|[
Note that in the three following macros the pattern argument is
processed at compile time while the template argument is processed at
runtime.
Note also, that the terminal position argument of tree-ref in the
template must be quoted, in case it is a singleton list. This is done by
quote-last
]|#

;;; (bind pat tpl . body)
;;; --------------------------
;;; Common Lisp's destructuring bind
;;; binds pattern variables of pat to corresponding subexpression of
;;; tpl and evalueates body in this context
(define-syntax bind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form))
            (tpl (caddr form))
            (xpr (cadddr form))
            (xprs (cddddr form)))
        `(if ((bindable? ,pat) ,tpl)
          (let
             ,(map (lambda (ks)
                     `(,(apply tree-ref pat ks)
                        (tree-ref ,tpl ,@(quote-last ks))))
                   (pindex pat))
             ,xpr ,@xprs)
          (error 'bind
                 (format #f "template ~s doesn't match pattern ~s"
                         ,tpl ',pat)))))))
;(define-syntax bind
;  (er-macro-transformer
;    (lambda (form rename compare?)
;      (let ((pat (cadr form))
;            (tpl (caddr form))
;            (xpr (cadddr form))
;            (xprs (cddddr form))
;            (%if (rename 'if))
;            (%let (rename 'let))
;            (%error (rename 'error))
;            (%format (rename 'format))
;            (%bindable? (rename 'bindable?))
;            (%tree-ref (rename 'tree-ref)))
;        `(,%if ((,%bindable? ,pat) ,tpl)
;          (,%let
;             ,(map (lambda (ks)
;                     `(,(apply tree-ref pat ks)
;                        (,%tree-ref ,tpl ,@(quote-last ks))))
;                   (pindex pat))
;             ,xpr ,@xprs)
;          (,%error 'bind
;                   (,%format #f "template ~s doesn't match pattern ~s"
;                             ,tpl ',pat)))))))

;;; (bind-case tpl (pat xpr . xprs) ....)
;;; -------------------------------------
;;; Checks if tpl matches pattern pat in sequence, binds the pattern
;;; variables of the first matching pattern to corresponding sublists of
;;; tpl and executes corresponding body xpr . xprs
(define-syntax bind-case
  (syntax-rules ()
    ((_ tpl (pat0  xpr0 . xprs0) (pat1 xpr1 . xprs1) ...)
     (cond
       (((bindable? pat0) tpl)
        (bind pat0 tpl  xpr0 . xprs0))
       (((bindable? pat1) tpl)
        (bind pat1 tpl  xpr1 . xprs1))
       ...
       (else
         (error 'bind-case (format #f "template ~s doesn't match any of the patterns ~s"
                                   tpl '(pat0 pat1 ...))))))))

#|[ 
old versions:
;;; (bind-define pat tpl)
;;; ---------------------
;;; defines pattern variables of the pattern pat by setting them to
;;; corresponding subexpressions of the template tpl
(define-syntax bind-define
  (ir-macro-transformer
    (lambda (form inject compare)
      (let ((pat (cadr form)) (tpl (caddr form)))
        (let ((aux (pmap (lambda (x) (gensym)) pat)))
          `(if ((bindable? ,pat) ,tpl)
             (bind ,aux ,tpl
               (begin
                 ,@(map (lambda (ks)
                          `(define
                             ,(apply tree-ref pat ks)
                             (tree-ref ,(cons 'list aux) ,@(quote-last ks))))
                        (pindex pat))))
             (error 'bind-define (format #f "template ~s doesn't match pattern ~s"
                                         ,tpl ',pat))))))))

;;; (bind-set! pat tpl)
;;; ---------------------
;;; sets pattern variables of the pattern pat to corresponding
;;; subexpressions of the template tpl
(define-syntax bind-set!
  (ir-macro-transformer
    (lambda (form inject compare)
      (let ((pat (cadr form)) (tpl (caddr form)))
        `(if ((bindable? ,pat) ,tpl)
           (begin
             ,@(map (lambda (ks)
                      `(set!
                         ,(apply tree-ref pat ks)
                         (tree-ref ,tpl ,@(quote-last ks))))
                    (pindex pat)))
           (error 'bind-set! (format #f "template ~s doesn't match pattern ~s" ,tpl ',pat)))))))

These versions would perfectly work, if tpl is simply a list, but not if
it is a list wrapped by a let storing common state. But the latter is
the most often used case of bind-define. The same applies to the
following version:

(define-syntax bind-define
  (syntax-rules ()
    ((_ (a . b) tpl)
     (begin
       (bind-define a (car tpl))
       (bind-define b (cdr tpl))))
    ((_ () tpl)
     (if (null? tpl) (void) (error 'bind-define "match error")))
    ((_ a tpl)
     (define a tpl))))

What we need is one further indirection provided in the following
versions, which first map the pattern, pat, to some auxiliary pattern,
aux, of the same form with gensym.
In bind-set! the template, tpl, is then bound to some variable x which
in turn can be bound to aux in the macro expansion. Since we used gensym
instead of rename above, there will be no name-clash - rename is
referentially transparent!
We could have used implicit-renaming macros as well, but then the
gensyms would be automatically renamed again, which isn't necessary.
]|#

;;; (bind-set! pat tpl)
;;; -------------------
;;; sets pattern variables of the pattern pat to corresponding
;;; subexpressions of the template tpl
(define-syntax bind-set!
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((pat (cadr form)) (tpl (caddr form)))
        (let ((aux (pmap gensym pat))
              ; rename would potentially clash with the %x below
              (%bind (rename 'bind))
              (%set! (rename 'set!))
              (%let (rename 'let))
              (%x (rename 'x)))
          `(,%let ((,%x ,tpl))
             (,%bind ,aux ,%x
               ,@(map (lambda (p a) `(,%set! ,p ,a))
                      (pflatten pat) (pflatten aux)))))))))
;(define-syntax bind-set!
;  (ir-macro-transformer
;    (lambda (form inject compare?)
;      (let ((pat (cadr form)) (tpl (caddr form)))
;        (let ((aux (pmap gensym pat)))
;          `(let ((x ,tpl))
;             (bind ,aux x
;               ,@(map (lambda (p a) `(set! ,p ,a))
;                      (pflatten pat) (pflatten aux)))))))))

;;; (bind-define pat tpl)
;;; ---------------------
;;; defines pattern variables of the pattern pat by setting them to
;;; corresponding subexpressions of the template tpl
(define-syntax bind-define
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((pat (cadr form)) (tpl (caddr form)))
        (let ((aux (pmap gensym pat))
              (%bind-set! (rename 'bind-set!))
              (%define (rename 'define))
              (%begin (rename 'begin)))
          `(,%begin
             (,%bind-set! ,aux ,tpl)
             ,@(map (lambda (p a) `(,%define ,p ,a))
                    (pflatten pat) (pflatten aux))))))))
;(define-syntax bind-define
;  (ir-macro-transformer
;    (lambda (form inject compare?)
;      (let ((pat (cadr form)) (tpl (caddr form)))
;        (let ((aux (pmap gensym pat)))
;          `(begin
;             (bind-set! ,aux ,tpl)
;             ,@(map (lambda (p a) `(define ,p ,a))
;                    (pflatten pat) (pflatten aux))))))))

;;; (bind-let* ((pat seq) ...) xpr . xprs)
;;; --------------------------------------
(define-syntax bind-let*
  (syntax-rules ()
    ((_ () xpr . xprs)
     (let () xpr . xprs))
    ((_ ((pat0 seq0) (pat1 seq1) ...) xpr . xprs)
     (bind pat0 seq0
       (bind-let* ((pat1 seq1) ...) xpr . xprs)))))

;;; (bind-let ((pat seq) ...) xpr . xprs)
;;; -------------------------------------
(define-syntax bind-let
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((binds (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        (let ((syms (map (lambda (x) (gensym)) binds)))
          `(bind ,syms ,(cons 'list (map cadr binds))
             (bind-let* ,(map (lambda (p s) `(,p ,s))
                              (map car binds)
                              syms)
               ,xpr ,@xprs)))))))

;;; (bind/cc k xpr . xprs)
;;; ----------------------
(define-syntax bind/cc
  (syntax-rules ()
    ((_ k xpr . xprs)
     (call-with-current-continuation
       (lambda (k) xpr . xprs)))))

#|[
Low-level-macros made easy
==========================
As an application of our binding macros, especially bind, we will now
provide macros define-macro, letrec-macro and let-macro to make
low-level macros easy.

The following two macros are internal. They are only used in
define-macro below
]|#

;;; (define-ir-macro (name . args)
;;;   (injecting (identifier ...)
;;;     (comparing ()|(suffix . suffixed-keywords)
;;;       . body)))
;;; -------------------------------------------------
;;; where transformer is a unary procedure accepting
;;; ir-macro-transformer' s last parameter, compare?
(define-syntax define-ir-macro
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((macro-code (cadr f))
            (inject-xpr (caddr f))
            (strip-suffix
              (lambda (suf id)
                (let ((sufstring (symbol->string suf))
                      (idstring (symbol->string id)))
                  (string->symbol
                    (substring idstring
                               0 
                               (- (string-length idstring)
                                  (string-length sufstring))))))))
        (let ((name (car macro-code))
              (args (cdr macro-code))
              (identifiers (cadr inject-xpr))
              (compare-xpr (caddr inject-xpr)))
          (let ((predicates (cadr compare-xpr))
                (body (caddr compare-xpr)))
            (cond
              ((and (null? identifiers) (null? predicates))
               `(define-syntax ,name
                  (ir-macro-transformer
                    (lambda (form inject compare?)
                      (bind ,args (cdr form)
                        ,body)))))
              ((null? predicates)
               `(define-syntax ,name
                  (ir-macro-transformer
                    (lambda (form inject compare?)
                      (bind ,args (cdr form)
                        (bind ,identifiers (map inject ',identifiers)
                          ,body))))))
              (else
                (let ((suffix (car predicates))
                      (suffixed-keywords (cdr predicates)))
                  (let ((syms (map (lambda (id) (strip-suffix suffix id))
                                   suffixed-keywords)))
                    (if (null? identifiers)
                      `(define-syntax ,name
                         (ir-macro-transformer
                           (lambda (form inject compare?)
                             (bind ,args (cdr form)
                               (bind ,suffixed-keywords
                                 (list ,@(map (lambda (s)
                                                `(lambda (n)
                                                   (compare? n ',(i s))))
                                              syms))
                                 ,body)))))
                      `(define-syntax ,name
                         (ir-macro-transformer
                           (lambda (form inject compare?)
                             (bind ,args (cdr form)
                               (bind ,identifiers (map inject ',identifiers)
                                 (bind ,suffixed-keywords
                                   (list ,@(map (lambda (s)
                                                  `(lambda (n)
                                                     (compare? n ',(i s))))
                                                syms))
                                   ,body)))))))))))))))))

;;; (define-er-macro (name . args)
;;;   (renaming (prefix . prefixed-identifiers)
;;;     (comparing ()|(suffix . suffixed-keywords)
;;;     . body)))
;;; -------------------------------------------------
;;; where transformer is a unary procedure accepting
;;; er-macro-transformer' s last parameter, compare?
(define-syntax define-er-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((macro-code (cadr f))
            (rename-xpr (caddr f))
            (strip-prefix (lambda (pre id)
                            (string->symbol
                              (substring (symbol->string id)
                                         (string-length
                                           (symbol->string pre))))))
            (strip-suffix
              (lambda (suf id)
                (let ((sufstring (symbol->string suf))
                      (idstring (symbol->string id)))
                  (string->symbol
                    (substring idstring
                               0 
                               (- (string-length idstring)
                                  (string-length sufstring))))))))
        (let ((name (car macro-code))
              (args (cdr macro-code))
              (prefix (caadr rename-xpr))
              (prefixed-identifiers (cdadr rename-xpr))
              (compare-xpr (caddr rename-xpr)))
          (let ((identifiers (map (lambda (id) (strip-prefix prefix id))
                                  prefixed-identifiers))
                (predicates (cadr compare-xpr))
                (body (caddr compare-xpr))
                (%er-macro-transformer (r 'er-macro-transformer))
                (%define-syntax (r 'define-syntax))
                (%compare? (r 'compare?))
                (%rename (r 'rename))
                (%lambda (r 'lambda))
                (%bind (r 'bind))
                (%list (r 'list))
                (%form (r 'form))
                (%cdr (r 'cdr))
                (%map (r 'map)))
            (if (null? predicates)
              `(,%define-syntax ,name
                  (,%er-macro-transformer
                    (,%lambda (,%form ,%rename ,%compare?)
                      (,%bind ,args (,%cdr ,%form)
                              (,%bind ,prefixed-identifiers
                                      (,%map ,%rename ',identifiers)
                                ,body)))))
              (let ((suffix (car predicates))
                    (suffixed-keywords (cdr predicates)))
                (let ((syms (map (lambda (id) (strip-suffix suffix id))
                                 suffixed-keywords)))
                  `(,%define-syntax ,name
                      (,%er-macro-transformer
                        (,%lambda (,%form ,%rename ,%compare?)
                          (,%bind ,args (,%cdr ,%form)
                            (,%bind ,prefixed-identifiers
                                    (,%map ,%rename ',identifiers)
                              (,%bind ,suffixed-keywords
                                      (,%list ,@(map (lambda (s)
                                                       `(lambda (n)
                                                          (,%compare? n (,%rename ',s))))
                                                     syms))
                                      ,body)))))))))))))))

;;; (define-macro (name . args)
;;;   [(injecting (identifier ...) | (renaming (prefix . prefixed-identifiers))]
;;;     [(comaring (suffix . suffixed-keywords)]
;;;       . body)))
;;; ----------------------------------------------------------------------------
(define-syntax define-macro
  (ir-macro-transformer 
    (lambda (form inject compare?)
      (if (not (= (length form) 3))
        (error 'define-macro "macro-code doesn't match pattern"
               '(_ macro-code body))
        (let ((macro-code (cadr form)) (body (caddr form)))
          ;; create standard body
          (let ((body (if (and (list? body)
                               (= (length body) 3)
                               (list? (cadr body)))
                        (cond
                          ((compare? (car body) 'comparing)
                           `(injecting () ,body))
                          ((compare? (car body) 'injecting)
                           (let ((rest (caddr body)))
                             (if (and (list? rest)
                                      (= (length rest) 3)
                                      (list? (cadr rest))
                                      (compare? (car rest) 'comparing))
                               body
                               `(injecting ,(cadr body)
                                  (comparing () ,(caddr body))))))
                          ((compare? (car body) 'renaming)
                           (let ((rest (caddr body)))
                             (if (and (list? rest)
                                      (= (length rest) 3)
                                      (list? (cadr rest))
                                      (compare? (car rest) 'comparing))
                               body
                               `(renaming ,(cadr body)
                                 (comparing () ,(caddr body))))))
                          (else
                            (error 'define-macro "not a macro body" body)))
                        `(injecting ()
                          (comparing () ,body)))))
            (if (compare? (car body) 'injecting)
              `(define-ir-macro ,macro-code ,body)
              `(define-er-macro ,macro-code ,body))))))))

;;; (letrec-macro ((macro-code tpl) ...) . body)
;;; --------------------------------------------
;;; defines local macros by binding recursively macro-codes to templates
;;; and evaluating body in this context.
(define-syntax letrec-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((binds (cadr f))
            (body (cddr f))
            (%letrec-syntax (r 'letrec-syntax)))
        `(,%letrec-syntax
           ,(map (lambda (m)
                   `(,(cadr m) ,(caddr m)))
                 (map (lambda (b)
                        (expand `(define-macro ,@b)))
                      binds))
           ,@body)))))

;;; (let-macro ((macro-code tpl) ...) . body)
;;; -----------------------------------------
;;; defines local macros by binding in parallel macro-codes to templates
;;; and evaluating body in this context.
(define-syntax let-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((binds (cadr f))
            (body (cddr f))
            (%let-syntax (r 'let-syntax)))
        `(,%let-syntax
           ,(map (lambda (m)
                   `(,(cadr m) ,(caddr m)))
                 (map (lambda (b)
                        (expand `(define-macro ,@b)))
                      binds))
           ,@body)))))

;;; (define-syntax-rule (macro-code) tpl)
;;; -------------------------------------
;;; simplyfies define-syntax in case there are no auxiliary keywords
;;; and only one syntax-rule.
(define-syntax define-syntax-rule
  (syntax-rules ()
    ((_ (name . args) tpl)
     (define-syntax name
       (syntax-rules ()
         ((_ . args) tpl))))))

(define (list-bindings)
  '(bind-define bind-set! bind bind-let* bind-let bind-case bindable? bind/cc
    define-macro let-macro letrec-macro define-syntax-rule tree-ref
    pflatten))

) ; module list-bindings