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

Copyright (c) 2011-2014, 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 package defines two libraries, macro-helpers and bindings. The former
exports a lot of procedures, most of which are needed in the latter,
some of them at compile-time.  The latter exports a series of macros,
most of them binding constructs, which gives the library its name. The
others are helpful in writing low-level macros. In particular,
macro-rules is as easy to use as syntax-rules, but much more powerful,
since it's a procedural macro and hence can do much of its work in local
procedures at compile-time.

The fundamental binding-construct, bind, is patterned after Paul
Graham's dbind, cf. "On Lisp", p. 232.
In Chicken, dbind for lists could look like as follows

  (define-syntax dbind
    (ir-macro-transformer
      (lambda (form inject compare?)
        (letrec (
          (mappend
            (lambda (fn lists)
              (apply append (map fn lists))))
          (destruc
            (lambda (pat seq)
              (let loop ((pat pat) (seq seq) (n 0))
                (if (pair? pat)
                  (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
                    (if (symbol? p)
                      (cons `(,p (list-ref ,seq ,n)) recu)
                      (let ((g (gensym)))
                        (cons (cons `(,g (list-ref ,seq ,n))
                                    (loop p g 0))
                              recu))))
                  (let ((tail `(list-tail ,seq ,n)))
                    (if (null? pat)
                      '()
                      `((,pat ,tail))))))))
          (dbind-ex
            (lambda (binds body)
              (if (null? binds)
                `(begin ,@body)
                `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
                            binds)
                   ,(dbind-ex
                      (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                               binds)
                      body)))))
          )         
          (let ((pat (cadr form))
                (seq (caddr form))
                (body (cdddr form))
                (gseq 'seq))
            `(let ((,gseq ,seq))
               ,(dbind-ex (destruc pat gseq) body)))))))

Note, that the destructuring procedures are local to this macro. This is
necessary in Chicken for the macro to work, in particular in compiled
code. We circumvent this problem by packaging the helpers in an extra
library, which can be required within a begin-for-syntax.
Note further, that ir-macro-transformer does all the necessary renaming
transparently behind the scene, even if the helpers are defined in
another module. In particular, gseq needn't be a gensym.
And note, that Graham's code didn't check for seq's length, i.e. 
(dbind (a b) '(1 2 3) (list a b) would happily return '(1 2).
This problem is tackled with dbind-len below.
And last, but not least, some macros should accept non-symbol literals,
in particular bind-case and macro-rules; dbind-lit will help here.
Another feature, which we would like to have, is a wild-card, represented
by the symbol underscore. It matches everything, but binds nothing. So
it can appear multiple times in the same macro.

We'll provide two versions of destruc, one for lists - or, to be more
precise, for nested pseudolists - and one for generic sequences.
]|#

(module macro-helpers
  (macro-helpers bind-exception symbol-dispatcher
   dbind-ex dbind-lit dbind-len dbind-def
   list-destruc seq-destruc remove-wildcards
   filter filter* flatten memp assp mappend map* flatten-map*
   plist? pnull? plength plist-ref plist-tail plist-head
   ptail phead singleton? collect* found?
   vector-head vector-tail list-of atom?
   extract adjoin remove-duplicates replace*
   seq-length seq-ref seq-tail seq-length! seq-ref! seq-tail!
   prefixed-with? strip-prefix strip-suffix add-prefix
   rename-prefix)

  (import scheme (only chicken
                       receive case-lambda define-values
                       let-values
                       make-parameter
                       error signal gensym print
                       make-property-condition
                       make-composite-condition))

(define (symbol-dispatcher alist)
  (case-lambda
    (()
     (map car alist))
    ((sym)
     (let ((pair (assq sym alist)))
       (if pair
         (for-each print (cdr pair))
         (print "Choose one of\n" (map car alist)))))))

(define macro-helpers
  (symbol-dispatcher '(
    (symbol-dispatcher
      (procedure: (alist) -> (procedure) or (procedure sym)))
    (bind-exception
      (procedure: (location message . arguments) -> condition))
    (map*
      (procedure: (fn . trees) -> new-tree))
    (flatten-map*
      (procedure: (fn . trees) -> new-list))
    (filter
      (procedure: (ok? lst) -> (ok-list not-ok-list)))
    (filter*
      (procedure: (ok? tree) -> (ok-tree not-ok-tree)))
    (flatten
      (procedure: (tree) -> lst))
    (collect*
      (procedure: (ok? tree) -> ok-list))
    (found?
      (procedure: (ok? tree) -> boolean))
    (extract
      (procedure: (ok? tree) -> lst))
    (memp
      (procedure: (ok? lst) -> sublst or #f))
    (assp
      (procedure: (ok? alst) -> pair or #f))
    (mappend
      (procedure: (fn lists) -> lst))
    (plength
      (procedure: (pl) -> pseudolength))
    (plist?
      (procedure: (xpr) -> boolean))
    (pnull?
      (procedure: (xpr) -> boolean))
    (plist-ref
      (procedure: (pl k) -> pseudo-kth-item))
    (plist-tail
      (procedure: (pl k) -> pseudo-kth-rest))
    (plist-head
      (procedure: (pl k) -> head-list-upto-k))
    (ptail
      (procedure: (pl) -> nil-or-atom))
    (phead
      (procedure: (pl) -> lst))
    (seq-length
      (procedure: (seq) -> generic-length))
    (seq-ref
      (procedure: (seq k) -> generic-kth-item))
    (seq-tail
      (procedure: (seq k) -> generic-kth-rest))
    (add-prefix
      (procedure: (prefix id) -> new-id))
    (prefixed-with?
      (procedure: (prefix) -> (procedure id)))
    (strip-prefix
      (procedure: (prefix id) -> new-id))
    (rename-prefix
      parameter:
      (rename-prefix sym ..)
      "sets rename-prefix to sym or returns it, default: '%")
    (strip-suffix
      (procedure: (suffix id) -> new-id))
    (adjoin
      (procedure: (obj lst) -> new-lst))
    (remove-duplicates
      (procedure: (lst) -> new-lst))
    (replace*
      (procedure: (what? by-fn tree) -> new-tree))
    (vector-head
      (procedure: (vec k) -> subvector))
    (vector-tail
      (procedure: (vec k) -> subvector))
    (list-of
      (procedure: (ok? ...) -> predicate))
    (atom?
      (procedure: (xpr) -> boolean))
    (singleton?
      (procedure: (xpr) -> boolean))
;    ;; should not be documented
;    (list-destruc
;      (procedure: (pat seq) or (pat seq glen gref gtail)
;                  -> (symbols literals length-checks)))
;    (seq-destruc
;      (procedure: (pat seq) or (pat seq glen gref gtail)
;                  -> (symbols literals length-checks)))
;    (remove-wildcards
;      (procedure: (compare? tree) -> reduced-tree))
;    (dbind-ex
;      (procedure: (symbols body) -> nested-let-code))
;    (dbind-lit
;      (procedure: (literals) -> literals-check-code))
;    (dbind-len
;      (procedure: (length-checks) -> length-check-code))
;    (dbind-def
;      (procedure: (op binds) -> define-code))
    )))

(define (bind-exception loc msg . args)
  (make-composite-condition
    (make-property-condition 'exn
      'location `(,loc)
      'message msg
      'arguments (apply list args))
    (make-property-condition 'bind
      'location `(,loc)
      'message msg
      'arguments (apply list args))))


;;;; pseudolists

(define (plist? xpr) #t)
  ;(or (atom? xpr)
  ;    (and (pair? xpr) (plist? (cdr xpr))))

(define (pnull? xpr)
  (or (null? xpr) (not (pair? xpr))))

(define (plist? xpr)
  (or (pnull? xpr) (pair? xpr)))

(define (plength pl)
  (let loop ((pl pl) (len 0))
    (if (pnull? pl)
      len
      (loop (cdr pl) (+ len 1)))))

;(define (plist-tail pl n)
;  (cond
;    ((or (negative? n) (> n (plength pl)))
;     (error 'plist-tail
;            "out of range"
;            pl n))
;    ((zero? n) pl)
;    (else
;     (plist-tail (cdr pl) (- n 1)))))
(define (plist-tail pl k)
  (if (or (< k 0) (> k (plength pl)))
    (error 'plist-tail "out of range" pl k)
    (let loop ((pl pl) (n 0) (result '()))
      (if (= n k)
        (values pl (reverse result))
        (loop (cdr pl) (+ n 1) (cons (car pl) result))))))

(define (plist-head pl k)
  (call-with-values
    (lambda () (plist-tail pl k))
    (lambda (tail head) head)))

(define (plist-ref pl n)
  (cond
    ((or (negative? n) (>= n (plength pl)))
     (error 'plist-ref
            "out of range"
            pl n))
    ((zero? n) (car pl))
    (else
     (plist-ref (cdr pl) (- n 1)))))

(define (ptail pl)
  (plist-tail pl (plength pl)))

(define (phead pl)
  (plist-head pl (plength pl)))

;;;; other helpers

(define (prefixed-with? pre)
  (lambda (id)
    (let ((pre-str (symbol->string pre))
          (id-str (symbol->string id)))
      (let ((pre-len (string-length pre-str)))
        (and (< pre-len (string-length id-str))
             (string=? pre-str
                       (substring id-str 0 pre-len)))))))

(define (add-prefix pre id)
  (string->symbol
    (string-append (symbol->string pre)
                   (symbol->string id))))

(define (strip-prefix pre id)
  (string->symbol
    (substring (symbol->string id)
               (string-length
                 (symbol->string pre)))))

(define (strip-suffix suf id)
  (let ((sufstring (symbol->string suf))
        (idstring (symbol->string id)))
    (string->symbol
      (substring idstring
                 0 
                 (- (string-length idstring)
                    (string-length sufstring))))))

(define (extract ok? tree)
  (remove-duplicates
    (filter ok? (flatten tree))))

(define (list-of . oks?)
  (lambda (obj)
    ;(not (memq #f (map (apply conjoin oks?) lst)))))
    (and (list? obj)
      (not (memq #f (map (lambda (xpr)
                           (let loop ((oks? oks?))
                             (cond
                               ((null? oks?) #t)
                               (((car oks?) xpr)
                                (loop (cdr oks?)))
                               (else #f))))
                         obj))))))

(define (atom? x)
  (not (pair? x)))

(define (singleton? xpr)
  (and (pair? xpr) (null? (cdr xpr))))

(define (map* fn . trees)
  (if (null? trees)
    '()
    (let loop ((trees trees))
      (cond
        (((list-of pair?) trees)
         (cons (loop (map car trees))
               (loop (map cdr trees))))
        (((list-of null?) trees)
         '())
        (((list-of atom?) trees)
         (apply fn trees))
        (else
          (error "not all of same structure" trees))))))

(define (flatten-map* fn . trees)
  (if (null? trees)
    '()
    (let loop ((trees trees))
      (cond
        (((list-of pair?) trees)
         (append (loop (map car trees))
                 (loop (map cdr trees))))
        (((list-of null?) trees)
         '())
        (((list-of atom?) trees)
         (list (apply fn trees)))
        (else
          (error "not all of same structure" trees))))))

(define (replace* what? by tree)
  (let loop ((tree tree))
    (cond
      ((what? tree) (by tree))
      ((pair? tree)
       (cons (loop (car tree))
             (loop (cdr tree))))
      ((null? tree) tree)
      (else tree))))

(define (memp ok? lst)
  (let loop ((lst lst))
    (if (null? lst)
      #f
      (if (ok? (car lst))
        lst
        (loop (cdr lst))))))

(define (assp ok? tbl)
  (let loop ((tbl tbl))
    (cond
      ((null? tbl) #f)
      ((ok? (caar tbl)) (car tbl))
      (else (loop (cdr tbl))))))

(define (filter ok? lst)
  (let loop ((lst lst) (yes '()) (no '()))
    (if (null? lst)
      (values (reverse yes) (reverse no))
      (let ((first (car lst)) (rest (cdr lst)))
        (if (ok? first)
          (loop rest (cons first yes) no)
          (loop rest yes (cons first no)))))))

(define (filter* ok? tree)
  (let loop ((tree tree))
    (cond
      ((pair? tree)
       (let-values (
         ((car-yes car-no) (loop (car tree)))
         ((cdr-yes cdr-no) (loop (cdr tree)))
         )
         (values (if (null? car-yes) cdr-yes (cons car-yes cdr-yes))
                 (if (null? car-no) cdr-no (cons car-no cdr-no)))))
      ((null? tree)
       (values '() '()))
      (else
        (if (ok? tree)
          (values tree '())
          (values '() tree))))))

(define (flatten tree)
  (let loop ((tree tree) (result '()))
    (cond
      ((pair? tree)
       (loop (car tree) (loop (cdr tree) result)))
      ((null? tree) result)
      (else
        (cons tree result)))))

(define (collect* ok? tree)
  (let loop ((tree tree) (result '()))
    (cond
      ((pair? tree)
       (if (ok? (car tree))
         (cons (car tree) (loop (cdr tree) result))
         (loop (car tree) (loop (cdr tree) result))))
      ((null? tree)
       result)
      (else
        (if (ok? tree)
          (cons tree result)
          result)))))

(define (found? ok? tree)
  (let loop ((tree tree))
    (cond
      ((pair? tree)
       (or (ok? (car tree))
           (loop (car tree))
           (loop (cdr tree))))
      ((null? tree) #f)
      (else (ok? tree)))))

(define (remove-duplicates lst)
  (let loop ((lst lst) (result '()))
    (if (null? lst)
      (reverse result)
      (loop (cdr lst) (adjoin (car lst) result)))))

(define (adjoin obj lst)
  (if (member obj lst) lst (cons obj lst)))

(define (mappend fn lists) ; mapcan in CL
  (apply append (map fn lists)))

#|[
Now to the destructuring procdures. Note that destruc will return three
values, which are used by one of the other destructuring routines
respectively.
]|#

(define (destruc pat seq glen gref gtail)
;(define (destruc pat seq glen glen-sym gref gtail)
  (let loop ((pat pat) (seq seq) (n 0))
    (if (pair? pat)
      (let ((p (car pat)))
        (receive (rec-ex rec-lit rec-len)
          (loop (cdr pat) seq (+ n 1))
          (if (or (pair? p) (null? p))
            (let ((g (gensym)) (v `(,gref ,seq ,n)))
              (receive (g-ex g-lit g-len) (loop p g 0)
                (values
                  (cons (cons `(,g (,gref ,seq ,n))
                              g-ex) rec-ex)
                  (cons (cons `(,g (,gref ,seq ,n))
                              g-lit) rec-lit)
                  (append (replace*
                            (lambda (x) (and (symbol? x) (eq? x g)))
                            (lambda (y) v)
                            g-len)
                          rec-len))))
            (if (symbol? p)
              (values
                (cons `(,p (,gref ,seq ,n)) rec-ex)
                rec-lit
                rec-len)
              (values
                rec-ex
                (cons `(,p (,gref ,seq ,n)) rec-lit)
                rec-len)))))
      (let ((tail `(,gtail ,seq ,n))
            (length-check (lambda (p s)
                            (if (list? p)
                              `(= (,glen ',p) (,glen ,s))
                              `(<= (,glen ',p) (,glen ,s))))))
                              ;`(= ,(glen p) (,glen-sym ,s))
                              ;`(<= ,(glen p) (,glen-sym ,s))))))
        (if (null? pat)
          (values '() '() `(,(length-check pat tail)))
          (if (symbol? pat)
            (values `((,pat ,tail)) '() `(,(length-check pat tail)))
            (values '() `((,pat ,tail)) `(,(length-check pat tail)))))))))

#|[
Two exported versions of destruc
]|#

(define (list-destruc pat seq)
  (destruc pat seq 'plength 'plist-ref 'plist-tail))

(define (seq-destruc pat seq)
  (destruc pat seq 'seq-length 'seq-ref 'seq-tail))

#|[
Four procedures which use the results of destruc
]|#

;; to be called with destruc's first return value
(define (dbind-ex symbols body)
  (if (null? symbols)
    `(if ,(car body)
       (begin ,@(cdr body))
       (signal (bind-exception 'dbind-ex
                               "fenders not passed"
                               ',(car body))))
    `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
                symbols)
       ,(dbind-ex
          (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                   symbols)
          body))))

;; to be called with destruc's second return value
(define (dbind-lit literals)
  (if (null? literals)
    #t
    (let ((pairs (map (lambda (b)
                        (if (pair? (car b))
                          (car b)
                          b))
                      literals)))
      (receive (syms lits)
        (filter (lambda (p) (symbol? (car p))) pairs)
        `(let ,syms
           (if (and ,@(map (lambda (s) (cons 'equal? s)) lits))
             ,(dbind-lit
                (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                         literals))
             (signal (bind-exception 'dbind-lit
                                     "literals don't match"
                                     ',lits))))))))

;; to be called with destruc's third return value
(define (dbind-len length-checks)
  `(condition-case (and ,@length-checks)
     ((exn)
      (signal (bind-exception 'dbind-len
                              "length-checks violated"
                              ',length-checks)))))

;; to be called with destruc's first return value
(define (dbind-def op binds)
  ;; Note, that gensyms don't pollute namespaces
  (if (null? binds)
    `(,op ,(gensym) (void))
    (let ((pairs (map (lambda (b)
                        (if (pair? (car b))
                          (car b)
                          b))
                      binds)))
      `(begin ,@(map (lambda (x) `(,op ,(car x) ,(cadr x)))
                     pairs)
              ,(dbind-def op
                          (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                                   binds))))))

;;; Please note, that these four helpers needn't care for renaming,
;;; since we'll implement dbind as an implicit renaming macro, which
;;; does the renaming automatically behind the scene. Even the gensym
;;; could be avoided by the same reason. But I prefer to have differnt
;;; names for repeated calls of a renaming procedure, which is
;;; guaranteed by gensym but violated by rename.


#|[ 
Now to the generic functions seq-ref, seq-tail and seq-length which can
be used as additional arguments in destruc, provided they are imported
for-syntax.
The following two macros help to avoid repetition of code.
]|#

(define-syntax search-and-call
  (syntax-rules ()
    ((_ tbl)
     (lambda args
       (let ((pair (assp (lambda (x) (x (car args)))
                         tbl))) ; choose method
         (if pair
           (apply (cdr pair) args) ; apply it
           (error 'search-and-call "type error" args)))))))

(define-syntax add-to-table
  (syntax-rules ()
    ((_ tbl)
     (lambda (pair)
       ;; pair must be added to the front
       ;; since last query of tbl, plist?,
       ;; is always #t
       (set! tbl (cons pair tbl))))))

#|[

Generic functions are in fact closures, which search a table for a
matching operation and apply that operation in case of a match.
To be able to add new operations to that table, we must get a handle on
it. In other words, there must be other routines which operate on the
same table. define-values will come to the rescue ...
]|#

(define-values (seq-length seq-length!)
  (let ((table
          (list
            (cons vector? vector-length)
            (cons string? string-length)
            ;; must be last, because plist? is always #t
            (cons plist? plength))))
    (values
      (search-and-call table)
      (add-to-table table))))

(define-values (seq-ref seq-ref!)
  (let ((table
          (list
            (cons vector? vector-ref)
            (cons string? string-ref)
            ;; must be last, because plist? is always #t
            (cons plist? plist-ref))))
    (values
      (search-and-call table)
      (add-to-table table))))

;; Chicken's subvector is buggy
(define (vector-tail seq n)
  (if (or (negative? n) (> n (vector-length seq)))
    (error 'vector-tail
           "out of range"
           seq n)
    (let* ((len (vector-length seq))
           (tail (make-vector (- len n) #f))
           (head (make-vector n #f)))
      (do ((k 0 (+ k 1)))
        ((= k len) (values tail head))
        (if (< k n)
          (vector-set! head k (vector-ref seq k))
          (vector-set! tail (- k n) (vector-ref seq k)))))))

(define (vector-head seq n)
  (call-with-values (lambda () (vector-tail seq n))
                    (lambda (tail head) head)))
    
(define-values (seq-tail seq-tail!)
  (let ((table
          (list
            (cons vector? vector-tail)
            (cons string? substring)
            ;; must be last, because plist? is always #t
            (cons plist? plist-tail))))
    (values
      (search-and-call table)
      (add-to-table table))))

(define rename-prefix
  (make-parameter '% (lambda (x) (if (symbol? x) x '%))))

(define (remove-wildcards compare? tree) 
  (let loop ((tree tree))
    (cond
      ((pair? tree)
       (let ((left (car tree)) (right (cdr tree)))
         (cond
           ((and (pair? left)
                 (symbol? (car left))
                 (compare? (car left) '_))
            (loop right))
           ((and (pair? right)
                 (symbol? (car right))
                 (compare? (car right) '_))
            (loop left))
           (else
             (cons (loop left)
                   (loop right))))))
      ((null? tree) '())
      (else
        (if (compare? tree '_)
          '()
          tree)))))

) ; module macro-helpers


#|[
The bindings module below should demonstrate the power of destructuring.
It exports a lot of binding constructs, the most important of it being
bind, which is a version of Common Lisp's destructuring-bind, but
destructures generic sequences, can check the bound variables in an
optional where clause and accepts non-symbol listerals, which
match only if they are equal. The latter is important for bind-case, a
version of matchable's match, and macro-rules, a low-level version of
syntax-rules.
Note, that the internal documentation uses special repeated dots besides
ellipses:
Two or four dots means: Repeat the expression on the left at most once
or at least once respectively.
]|#
(module bindings
  (bindings seq-length-ref-tail! define-syntax-rule
   bindable?  bind-case bind-let bind-let* bind-letrec
   bindrec bind-lambda bind-lambda* bind* bind-set!
   bind bind-define bind-case-lambda bind-case-lambda*
   bind/cc macro-rules define-macro define-er-macro
   let-er-macro letrec-er-macro let-macro letrec-macro
   with-gensyms once-only)


  (import scheme
          (only chicken
                condition-case 
                print gensym
                current-exception-handler
                make-property-condition
                condition-predicate
                get-condition-property
                signal abort)
          (only macro-helpers
                list-of
                rename-prefix
                bind-exception
                seq-length! seq-ref! seq-tail!
                seq-length seq-ref seq-tail
                replace*
                bind-exception
                symbol-dispatcher))
  (reexport (only macro-helpers
                  list-of
                  bind-exception))

  (import-for-syntax (only macro-helpers
                           remove-wildcards
                           rename-prefix
                           extract
                           collect*
                           flatten-map*
                           map*
                           mappend
                           replace*
                           plength
                           plist-ref
                           plist-tail
                           seq-length
                           seq-ref
                           seq-tail
                           found?
                           collect*
                           prefixed-with?
                           strip-prefix
                           list-destruc
                           seq-destruc
                           dbind-ex
                           dbind-lit
                           dbind-len
                           dbind-def)
                     (only chicken
                           receive
                           condition-case))
  

#|[
Documentation dispatcher
]|#
(define bindings
  (symbol-dispatcher '(
    (bind-set!
      macro:
      (bind-set! pat seq)
      "sets multiple variables by destructuring its sequence argument")
    (bind-define
      macro:
      (bind-define pat seq)
      "defines multiple variables by destructuring its sequence argument")
    (bind
      macro:
      (bind pat seq (where . fenders) .. xpr ....)
      "a variant of Common Lisp's destructuring-bind")
    (bindable?
      macro:
      (bindable? pat . fenders)
      "returns a unary predicate, which checks"
      "if its argument matches pat and passes all fenders")
    (bind-lambda
      macro:
      (bind-lambda pat (where . fenders) .. xpr ....)
      "combination of lambda and bind, one pattern argument")
    (bind-lambda*
      macro:
      (bind-lambda* pat (where . fenders) .. xpr ....)
      "combination of lambda and bind, multiple pattern arguments")
    (bindrec
      macro:
      (bindrec pat seq (where . fenders) .. xpr ....)
      "recursive version of bind")
    (bind*
      macro:
      (bind* loop pat seq (where . fenders) .. xpr ....)
      "named version of bind")
    (bind-let
      macro:
      (bind-let loop .. ((pat seq) ...) xpr ....)
      "nested version of let, named and unnamed")
    (bind-let*
      macro:
      (bind-let* ((pat seq) ...) xpr ....)
      "nested version of let*")
    (bind-letrec
      macro:
      (bind-letrec ((pat seq) ...) xpr ....)
      "recursive version of bind-let")
    (bind-case
      macro:
      (bind-case seq (pat (where . fenders) .. xpr ....) ....)
      "matches seq against pat with optional fenders in a case regime")
    (bind-case-lambda
      macro:
      (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
      "combination of lambda and bind-case with one pattern argument")
    (bind-case-lambda*
      macro:
      (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
      "combination of lambda and bind-case with multiple pattern arguments")
    (bind/cc
      macro:
      (bind/cc cc xpr ....)
      "binds cc to the current contiunation"
      "and execute xpr ... in this context")
    (macro-rules
      macro:
      (macro-rules literal ... (keyword ...) (pat tpl) ....)
      "low-level version of syntax-rules"
      "with optional injected literals"
      "and quasiquoted templates")
    (define-macro
      macro:
      one-of
      (define-macro name macro-rules-expression)
      (define-macro (name . args) xpr ....)
      (define-macro (name . args) (keywords x ...) xpr ....)
      (define-macro (name . args) (inject y ...) xpr ....)
      (define-macro (name . args) (inject y ...) (keywords x ...) xpr ....)
      (define-macro (name . args) (keywords x ...) (inject y ...) xpr ....)
      "alternatives to define-syntax using macro-rules")
    (let-macro
      macro:
      (let-macro ((name macro-rules-expression) ....) xpr ....)
      "alternative to let-syntax using macro-rules")
    (letrec-macro
      macro:
      (letrec-macro ((name macro-rules-expression) ....) xpr ....)
      "alternative to letrec-syntax using macro-rules")
    (define-er-macro
      macro:
      (define-er-macro (name . args) (keywords key ...) .. xpr ....)
      "explicit-renaming macro where prefixed symbols are renamed"
      "The prefix is taken from the parameter rename-prefix")
    (let-er-macro
      macro:
      (let-er-macro ((code tpl) ...) xpr ....) 
      "local parallel version of define-er-macro")
    (letrec-er-macro
      macro:
      (letrec-er-macro ((code tpl) ...) xpr ....) 
      "local recursive version of define-er-macro")
    (define-syntax-rule
      macro:
      (define-syntax-rule (name . args) (keywords x ...) .. tpl)
      "syntax-rules with only one rule")
    (with-gensyms
      macro:
      (with-gensyms (x ....) xpr ....)
      "generates a series of gensyms x .... to be used in xpr ...")
    (once-only
      macro:
      (once-only (x ....) xpr ....)
      "arguments x ... are evaluated only once")
    (list-of
      (procedure: (ok? ...) -> bool))
    (bind-exception
      (procedure: (location message . arguments) -> condition))
    (seq-length-ref-tail!
      (procedure: (type? type-length type-ref type-tail)
                  updates (seq-length seq-ref seq-tail)))
    )))

#|[
The following two macros are here for convenience. The first two are
of great help in writing low-level macros, the last ony simplifies
high-level macros with only one rule.
]|#

;;; (with-gensyms (name ...) . body)
;;; --------------------------------
;;; binds name ... to (gensym 'name) ... in body
(define-syntax with-gensyms
  (ir-macro-transformer
    (lambda (form inject compare?)
      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
         ,@(cddr form)))))

;;; (once-only (x ...) . body)
;;; --------------------------
;;; macro-arguments x ... are only evaluated once and from left to right
(define-syntax once-only
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((names (cadr form))
            (body (cddr form))
            (%let (rename 'let))
            (%list (rename 'list))
            (%gensym (rename 'gensym)))
        (let ((gensyms (map gensym names)))
          `(,%let ,(map (lambda (g) `(,g (,%gensym))) gensyms)
             (,%list ',%let ,(cons %list
                               (map (lambda (g n) `(,%list ,g ,n))
                                    gensyms names))
                (,%let ,(map (lambda (n g) `(,n ,g)) names gensyms)
                   ,@body))))))))

;;; (define-syntax-rule (name . args) (keywords . keys) .. tpl)
;;; -----------------------------------------------------------
;;; simplyfies define-syntax in case there is only one syntax-rule
(define-syntax define-syntax-rule
  (syntax-rules (keywords)
    ((_ (name . args)
        (keywords key ...) tpl)
     (define-syntax name
       (syntax-rules (key ...)
         ((_ . args) tpl))))
    ((_ (name . args) tpl)
     (define-syntax name
       (syntax-rules ()
         ((_ . args) tpl))))))

#|[
Let's start with a new exception-handler, which is able to cope with
bind exceptions
]|#

(current-exception-handler
  (let ((old-handler (current-exception-handler)))
    (lambda (var)
      (if ((condition-predicate 'bind) var)
        (begin
          (display "Error: ")
          (print (get-condition-property var 'bind 'location))
          (print (get-condition-property var 'bind 'message))
          (for-each print (get-condition-property var 'bind 'arguments))
          (abort (make-property-condition 'exn
                   'message "exception-handler returned")))
        (old-handler var)))))

#|[ 
The first two macros are nested versions of set! and define. They allow
the simultaneous definition of procedures which have access to common
state. In fact, it suffices to implement bind-set! since Chicken
reduces define to set! anyway: try (expand '(define a 1)) to convince
yourself.  So we could implement bind-define as an alias to bind-set!
But according to the standard, set! changes existing variables, while
define defines new ones. So our definition will reflect this.

bind-set! replaces the values of symbols in a nested lambda-list in one
go with the corresponding subeseqessions of its second argument. So,
after (bind-set! (a (b (c . d))) '(1 (2 (3 4 5)))) d should have the
value (4 5), b the value 2 etc.
bind-define does the same, but defines the pattern variables before
setting them. The real advantage of this is, that we can define several
functions which rely on the same encapsulated state. Consider

  (bind-define (push top pop)
    (let ((state '()))
      (list
        (lambda (arg) (set! lst (cons arg state)))
        (lambda () (car state))
        (lambda () (set! lst (cdr state))))))

Now we have three procedures, which all operate on the encapsulated
list.

The implementation uses the fourth procedure, dbind-def, which operates
on the return values of seq-destruc.
]|#

;;; (bind-define pat seq)
;;; ---------------------
;;; destructures the sequence seq according to the pattern pat and sets
;;; pattern variables with values corresponding to subexpressions of seq
(define-syntax bind-define
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form)) (seq (caddr form)) (gseq 'seq))
        `(begin (define ,gseq ,seq)
                ,(dbind-def 'define (seq-destruc pat gseq)))))))

;;; (bind-set! pat seq)
;;; -------------------
;;; destructures the sequence seq according to the pattern pat and
;;; defines pattern variables with values corresponding to
;;; subexpressions of seq
(define-syntax bind-set!
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form)) (seq (caddr form)) (gseq 'seq))
        `(begin (set! ,gseq ,seq)
                ,(dbind-def 'set! (seq-destruc pat gseq)))))))


#|[
Now we'll extend Graham's dbind, allowing non-symbols in the patterns,
which must be equal to the corresponding values in the template for a
match.
]|#

(define-syntax dbind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form))
            (seq (caddr form))
            (body (cdddr form))
            (gseq 'seq))
        `(let ((,gseq ,seq))
           ,(receive (symbols literals checks)
              (seq-destruc pat seq)
              `(if ,(dbind-len checks)
                 (if ,(dbind-lit literals)
                   ;,(dbind-ex symbols body)
                   ,(dbind-ex (remove-wildcards compare? symbols)
                              body)
                   (signal
                     (bind-exception 'dbind
                                     "literals don't match"
                                     ',literals)))
                 (signal (bind-exception 'dbind
                                         "not matchable"
                                         ',pat ,gseq)))))))))
     
;;; (bind pat seq (where . fenders) .. xpr . xprs)
;;; ----------------------------------------------
;;; binds pattern variables of pat to corresponding subexpressions of
;;; seq and executes tthe body xpr . xprs in this context. If a where
;;; expression is supplied, all fenders must return #t for seq to be
;;; successfully bound.
(define-syntax bind
  (syntax-rules (where)
    ((_ pat seq (where . fenders) xpr . xprs)
     (dbind pat seq (and . fenders) xpr . xprs))
    ((_ pat seq xpr . xprs)
     (dbind pat seq #t xpr . xprs))))

#|[
The next macro, bindable?, can be used to check, if a
sequence-expression matches a pattern and passes all fenders. It's used
in bind-case below.
The implementation relies on bind, which must be protected against exceptions.
]|#

;;; (bindable? pat . fenders)
;;; -------------------------
;;; returns a unary predicate which checks, if its argument matches pat
;;; and fulfills the predicates in the list fenders
(define-syntax-rule (bindable? pat . fenders)
  (lambda (seq)
    (condition-case
      (bind pat seq (and . fenders))
      ((exn bind) #f))))

#|[
Now we can define two macros, which simply combine lambda with
bind, the first destructures simply one argument, the second a
whole list. An example of a call and its result is

  ((bind-lambda (a (b . c) . d) (list a b c d))
   '(1 #(20 30 40) 2 3))
  -> '(1 20 #(30 40) (2 3)))))

  ((bind-lambda* ((a (b . c) . d) (e . f))
     (list a b c d e f))
   '(1 #(20 30 40) 2 3) '#(4 5 6))
  -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
]|#

;;; (bind-lambda pat xpr . xprs)
;;; --------------------------------
;;; combination of lambda and bind, one pattern argument
(define-syntax bind-lambda
  (syntax-rules (where)
    ((_ pat (where . fenders) xpr . xprs)
     (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
    ((_ pat xpr . xprs)
     (lambda (x) (bind pat x xpr . xprs)))))

;;; (bind-lambda* pat xpr . xprs)
;;; ---------------------------------
;;; combination of lambda and bind, multiple pattern arguments
(define-syntax bind-lambda*
  (syntax-rules (where)
    ((_ pat (where . fenders) xpr . xprs)
     (lambda x (bind pat x (where . fenders) xpr . xprs)))
    ((_ pat xpr . xprs)
     (lambda x (bind pat x xpr . xprs)))))

#|[
The following macro, bind*, is a named version of bind. It takes an
additional argument besides those of bind, which is bound to a
recursive procedure, which can be called in bind's body. The pattern
variables are initialised with the corresponding subexpressions in seq.
For example

  (bind* loop (x y) '(5 0)
    (if (zero? x)
      (list x y)
      (loop (list (sub1 x) (add1 y)))))
  -> '(0 5)
]|#

;;; (bind* name pat seq (where . fenders) .. xpr . xprs)
;;; ---------------------------------------------------------
;;; named version of bind
(define-syntax bind*
  (syntax-rules (where)
    ((_ loop pat seq (where . fenders) xpr . xprs)
     ((letrec ((loop 
                 (bind-lambda pat (where . fenders) xpr . xprs)))
                 ;(lambda (x)
                 ;  (bind pat x (where . fenders) xpr . xprs))))
        loop)
      seq))
    ((_ loop pat seq xpr . xprs)
     (bind* loop pat seq (where) xpr . xprs))))

#|[
And here is the recursive version of bind.

  (bindrec ((o?) e?)
    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    (list (o? 95) (e? 95)))
  -> '(#t #f)

It's definition is patterned after a procedural definition of letrec:

  (define-macro (my-letrec pairs . body)
    (let ((vars (map car pairs))
          (vals (map cadr pairs))
          (aux (map (lambda (x) (gensym)) pairs)))
      `(let ,(map (lambda (var) `(,var #f)) vars)
         (let ,(map (lambda (a v) `(,a ,v)) aux vals)
           ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
           ,@body))))

Note, how simple this is, compared with the syntax-rules definition in
R5RS
]|#

;;; (bindrec pat seq (where . fenders) .. xpr ....)
;;; ----------------------------------------------------
;;; recursive version of bind
(define-syntax bindrec
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form))
            (seq (caddr form))
            (xpr (cadddr form))
            (xprs (cddddr form)))
        (let ((aux (map* gensym pat)))
          `(let ,(flatten-map* (lambda (v) `(,v #f)) pat)
             (dbind ,aux ,seq
               ,@(flatten-map* (lambda (x y) `(set! ,x ,y))
                               pat aux)
               (if ,(and (pair? xpr) (compare? (car xpr) 'where))
                 (if (and ,@(cdr xpr))
                   (begin ,@xprs)
                   (signal (bind-exception 'bindrec
                                           "fenders not passed"
                                           ',(cdr xpr))))
                 (begin ,xpr ,@xprs)))))))))

#|[
Now the implementation of a nested version of let, named and unnamed,
is easy: Simply combine bind and bind*. For example

  (bind-let (
     (((x y) z) '((1 2) 3))
     (u (+ 2 2))
     ((v w) '(5 6))
     )
     (list x y z u v w))
  -> '(1 2 3 4 5 6)

  (bind-let loop (((a b) '(5 0)))
    (if (zero? a)
      (list a b)
      (loop (list (sub1 a) (add1 b)))))
  -> '(0 5)
]|#

;;; (bind-let loop .. ((pat seq) ...) xpr . xprs)
;;; ---------------------------------------------
;;; nested version of let, named and unnamed
(define-syntax bind-let
  (syntax-rules ()
    ((_ () xpr . xprs)
     (begin xpr . xprs))
    ((_ ((pat0 seq0) (pat1 seq1) ...) xpr . xprs)
     (bind (pat0 pat1 ...) (list seq0 seq1 ...) xpr . xprs))
    ((_ loop () xpr . xprs)
     (let loop () xpr . xprs))
    ((_ loop ((pat0 seq0) ...) xpr . xprs)
     (bind* loop (pat0 ...) (list seq0 ...) xpr . xprs))))

#|[
The sequential version of bind-let should work as follows

  (bind-let* (
     (((x y) z) '((1 2) 3))
     (u (+ 1 2 x))
     ((v w) (list (+ z 2) 6))
     )
     (list x y z u v w))
  -> '(1 2 3 4 5 6)
]|#

;;; (bind-let* ((pat seq) ...) xpr . xprs)
;;; --------------------------------------
;;; sequential version of bind-let
(define-syntax bind-let*
  (syntax-rules ()
    ((_ () xpr . xprs)
     (let () xpr . xprs))
    ((_ ((pat seq) . pairs) xpr . xprs)
     (bind pat seq (bind-let* pairs xpr . xprs)))))

#|[
The recursive version of bind-let works as follows
  
  (bind-letrec (
    ((o? (e?))
     (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
           (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    )
    (list (o? 95) (e? 95)))
  -> '(#t #f)
]|#

;;; (bind-letrec ((pat seq) ...) xpr . xprs)
;;; ----------------------------------------
;;; recursive version of bind-let
(define-syntax-rule (bind-letrec ((pat seq) ...) xpr . xprs)
  (bindrec (pat ...) (list seq ...) xpr . xprs))

#|[
The following macro does more or less the same what the match macro from
the matchable package does, for example

  (bind-case '(1 (2 3))
    ((x y) (where (list? y)) (list x y))
    ((x (y . z)) (list x y z))
    ((x (y z)) (list x y z))) ;-> '(1 2 (3))

or, to give a more realistic example, mapping:

  (define (my-map fn lst)
    (bind-case lst
      (() '())
      ((x . xs) (cons (fn x) (my-map fn xs)))))
]|#

;;; (bind-case seq (pat (where . fenders) .. xpr . xprs) ....)
;;; ----------------------------------------------------------
;;; Checks if seq matches pattern pat [satisfying fenders] ....
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; corresponding body xpr . xprs
(define-syntax bind-case
  (syntax-rules (where)
    ((_ seq (pat (where . fenders) xpr . xprs) . clauses)
     (condition-case
       (bind pat seq (where . fenders) xpr . xprs)
       ((exn bind) (bind-case seq . clauses))))
    ((_ seq (pat xpr . xprs) . clauses)
     (condition-case
       (bind pat seq xpr . xprs)
       ((exn bind) (bind-case seq . clauses))))
    ((_ seq)
     (signal (bind-exception 'bind-case
                             "no rule matches"
                             seq)))
    ))

#|[ 
The next two macros combine lambda and bind-case and do more or less the
same as match-lambda and match-lambda* in the matchable package. The
first destructures one argument, the second a list of arguments.
Here is an example together with its result:

  ((bind-case-lambda
     ((a (b . c) . d) (list a b c d))
     ((e . f) (where (zero? e)) e)
     ((e . f) (list e f)))
   '(1 2 3 4 5))
  -> '(1 (2 3 4 5))

  ((bind-case-lambda*
     (((a (b . c) . d) (e . f))
      (list a b c d e f)))
   '(1 #(20 30 40) 2 3) '(4 5 6))
  -> '(1 20 #(30 40) (2 3) 4 (5 6))
]|#

;;; (bind-case-lambda (pat (where . fenders) .. xpr . xprs) ....)
;;; -------------------------------------------------------------
;;; combination of lambda and bind-case, one pattern argument
(define-syntax bind-case-lambda
  (syntax-rules (where)
    ((_ (pat (where . fenders) xpr . xprs))
     (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
    ((_ (pat xpr . xprs))
     (lambda (x) (bind pat x xpr . xprs)))
    ((_ clause . clauses)
     (lambda (x)
       (bind-case x clause . clauses)))))

;;; (bind-case-lambda* (pat (where . fenders) .. xpr . xprs) ....)
;;; --------------------------------------------------------------
;;; combination of lambda and bind-case, multiple pattern arguments
(define-syntax bind-case-lambda*
  (syntax-rules (where)
    ((_ (pat (where . fenders) xpr . xprs))
     (lambda x (bind pat x (where . fenders) xpr . xprs)))
    ((_ (pat xpr . xprs))
     (lambda x (bind pat x xpr . xprs)))
    ((_ clause . clauses)
     (lambda x
       (bind-case x clause . clauses)))))

;;; (bind/cc cc xpr ....)
;;; ---------------------
;;; captures the current continuation, binds it to cc and executes
;;; xpr .... in this context
(define-syntax-rule (bind/cc cc xpr . xprs)
  (call-with-current-continuation
    (lambda (cc) xpr . xprs)))

#|[
Now we'll use macro-helpers and binding-macros to implement macros,
which implement macros. The first, macro-rules, is a low-level version
of syntax-rules. It is as convenient as the latter, but much more
powerfull. For example, it can use injected symbols, do some of its work
at compile-time, use local functions at compile-time and what have you.
Contrary to syntax-rules the templates usually evaluate to quasiquoted
expressions.
]|#

;;; (macro-rules sym ... (key ...)
;;;   (pat tpl) ....)
;;; ------------------------------
;;; where sym ... are injected non-hygienig symbols, key ... are
;;; additional keywords, pat ....  are nested lambda-lists without
;;; spezial meaning of ellipses and tpl .... evaluate to
;;; quasiquoted templates.
(define-syntax macro-rules
  (ir-macro-transformer
    (lambda (f i c?)
      ;; injections is list of injected syms, tail starts with keyword-list
      (receive (tail injections)
        (let loop ((tail (cdr f)) (injections '()))
          (if (list? (car tail)) ; keyword list
            (values tail injections)
            (loop (cdr tail) (cons (car tail) injections))))
          (let ((keywords (car tail))
                (rules (cdr tail))
                (inject-sym (lambda (h) `(,h (inject ',h)))))
            (if (null? rules)
              `(signal (bind-exception 'macro-rules "no rule matches"))
              (let (
                (once? (lambda (x) (and (pair? x) (c? (car x) 'once))))
                (extract-keywords
                  (lambda (r) (extract (lambda (y) (memq y keywords)) r)))
                (process-injections
                  (lambda (binds)
                    (if (null? injections)
                      binds
                      `(let ,(map inject-sym injections)
                         ,binds))))
                )
                (let (
                  (process-keywords
                    (lambda (r)
                      ;; doesn't work whith where clauses
                      ;`(,(car r)
                      ;   (where ,@(map (lambda (p s) `(compare? ,p ,s))
                      ;                 (extract-keywords (cddar r))
                      ;                 (map (lambda (x) `',x)
                      ;                      (extract-keywords (cddar r)))))
                      ;   ,@(cdr r))))
                      (let* ((kws (extract-keywords (cddar r)))
                             ;; compare? keywords with its names
                             (keys (map (lambda (p s) `(compare? ,p ,s))
                                          kws (map (lambda (x) `',x) kws)))
                             ;; add keyword-clauses to where-clauses
                             (wheres (if (c? (caadr r) 'where)
                                       (append keys (cdadr r))
                                       keys)))
                        ;; replace first item in template
                        `(,(car r)
                             (where ,@wheres)
                           ,@(if (null? (cddr r)) (cdr r) (cddr r))))))
                  (process-onces
                    (lambda (r)
                      (let ((args (cdar r)))
                        (if (found? once? args)
                          (let (
                            (osyms (map cadr (collect* once? args)))
                            (vars (replace* once? cadr args))
                            )
                            `((_ ,@vars) (once-only ,osyms ,@(cdr r))))
                          `((_ ,@args) ,@(cdr r))))))
                  (process-wrapper
                    (lambda (binds)
                      `(ir-macro-transformer
                         (lambda (form inject compare?)
                           ,(process-injections binds)))))
                  )
                  (if (null? keywords)
                    (process-wrapper
                      `(bind-case form ,@(map process-onces rules)))
                    (process-wrapper
                      `(bind-case form
                         ,@(map process-keywords
                                (map process-onces rules)))))))))))))

;;; (define-macro (name . args)
;;;   (inject sym ...) ..
;;;   (keywords key ...) ..
;;;   xpr ....)
;;; ---------------------------
(define-syntax define-macro
  (syntax-rules (inject keywords macro-rules)
    ;; without injections
    ((_ name (macro-rules (key ...) xpr . xprs))
     (define-syntax name
       (macro-rules (key ...) xpr .  xprs)))
    ;; with injections
    ((_ name (macro-rules syms keys xpr . xprs))
     (define-syntax name
       (macro-rules syms keys xpr .  xprs)))
    ((_ (name . args) (inject sym ...) (keywords key ...) xpr . xprs)
     (define-syntax name
       (macro-rules sym ... (key ...) ((_ . args) xpr . xprs))))
    ((_ (name . args) (keywords key ...) (inject sym ...) xpr . xprs)
     (define-syntax name
       (macro-rules sym ... (key ...) ((_ . args) xpr . xprs))))
    ((_ (name . args) (inject sym ...) xpr . xprs)
     (define-syntax name
       (macro-rules sym ... () ((_ . args) xpr . xprs))))
    ((_ (name . args) (keywords key ...) xpr . xprs)
     (define-syntax name
       (macro-rules (key ...) ((_ . args) xpr . xprs))))
    ((_ (name . args) xpr . xprs)
     (define-syntax name
       (macro-rules () ((_ . args) xpr . xprs))))))

;;; (let-macro ((name macro-rules-xpr) ....) xpr ....)
;;; --------------------------------------------------
;;; binds macro-rules-xpr .... locally and in parallel to name ....
;;; and executes xpr .... in this context
(define-syntax let-macro
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((bindings (cadr f))
            (body (cddr f)))
        (let ((names (map car bindings))
              (rules (map cadr bindings)))
        (let ((names (map car bindings))
              (rules (map cadr bindings)))
          (let loop ((lst (map car rules)))
            (cond
              ((null? lst)
               `(let-syntax ,(map (lambda (n r) `(,n ,r))
                                  names rules)
                            ,@body))
              ((c? (car lst) 'macro-rules)
               (loop (cdr lst)))
              (else
                `(signal (bind-exception 'letrec-macro "no rule matches")))))))))))

;;; (letrec-macro ((name macro-rules-xpr) ....) xpr ....)
;;; -----------------------------------------------------
;;; binds macro-rules-xpr .... locally and recursively to name ....
;;; and executes xpr .... in this context
(define-syntax letrec-macro
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((bindings (cadr f))
            (body (cddr f)))
        (let ((names (map car bindings))
              (rules (map cadr bindings)))
          (let loop ((lst (map car rules)))
            (cond
              ((null? lst)
               `(letrec-syntax ,(map (lambda (n r) `(,n ,r))
                                     names rules)
                               ,@body))
              ((c? (car lst) 'macro-rules)
               (loop (cdr lst)))
              (else
                `(signal (bind-exception 'letrec-macro "no rule matches"))))))))))

;;; (define-er-macro (name . args)
;;;   (rename-prefix pre)   ;;;
;;;   (keywords key ...) ..
;;;   xpr ....)
;;; ------------------------------
(define-syntax define-er-macro
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((code (cadr f))
            (body (cddr f))
            (once? (lambda (x)
                     (and (pair? x) (c? (car x) 'once))))
            (pre (rename-prefix)))
        (let (
          (name (car code))
          (args (cdr code))
          (keywords? (c? (caar body) 'keywords))
          )
          (let (
            (process-renames
              (lambda (b)
                (map (lambda (s)
                        `(,s (rename
                               ',(strip-prefix pre
                                               (i s)))))
                      (extract (prefixed-with? pre) b))))
            (process-keywords
              (lambda (vs ks)
                (if keywords?
                  `(and ,@(map (lambda (x y) `(compare? ,x ,y))
                               (extract (lambda (a) (memq a ks))
                                        (cdr vs))
                               (map (lambda (b) `',b)
                                    (extract (lambda (a) (memq a ks))
                                             (cdr vs)))))
                   #t)))
            (process-wrapper
              (lambda (binds)
                `(define-syntax ,name
                   (er-macro-transformer
                     (lambda (form rename compare?)
                       (condition-case
                         ,binds
                         ((exn bind)
                          (signal (bind-exception 'define-er-macro
                                                  "no match")))))))))
            )
            (let ((keys (if keywords? (cdar body) '()))
                  (body (if keywords? (cdr body) body)))
              (if (found? once? args)
                (let ((osyms (map cadr (collect* once? args)))
                      (vars (replace* once? cadr args)))
                  (process-wrapper
                    `(dbind ,vars
                            (cdr form)
                            ,(process-keywords vars keys)
                            (let ,(process-renames body)
                              (once-only ,osyms ,@body)))))
                (process-wrapper
                  `(dbind ,args
                          (cdr form)
                          ,(process-keywords args keys)
                          (let ,(process-renames body)
                            ,@body)))))))))))

;;; (letrec-er-macro ((macro-code tpl) ...) . body)
;;; -----------------------------------------------
;;; defines local macros by binding recursively macro-codes to templates
;;; and evaluating body in this context.
(define-syntax letrec-er-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-er-macro ,@b)))
                      binds))
           ,@body)))))

;;; (let-er-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-er-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-er-macro ,@b)))
                      binds))
           ,@body)))))

;;; (seq-length-ref-tail! type? type-length type-ref type-tail)
;;; -----------------------------------------------------------
;;; updates the tables with tree functions in this order and index it
;;; with the type predicate type?.
(define (seq-length-ref-tail! type? type-length type-ref type-tail)
  (seq-length! (cons type? type-length))
  (seq-ref!    (cons type? type-ref))
  (seq-tail!   (cons type? type-tail)))

) ; module bindings