#|[
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.
]|#


#|[
First a helper module, which might be useful not only in
low-level-macros.
]|#

(module macro-helpers
  (export macro-helpers bind-exception symbol-dispatcher
          destruc dbind-ex dbind-lit dbind-len
          filter flatten memp assp mappend
          plist? pnull? plength plist-ref plist-tail
          prefixed-with? strip-prefix strip-suffix
          extract adjoin remove-duplicates substitute*
          seq-length seq-ref seq-tail seq-length-ref-tail!)
  (import scheme (only chicken receive case-lambda 
                       define-values 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))
    (destruc
      (procedure: (pat seq) or (pat seq glen gref gtail)
                  -> (symbols literals length-checks)))
    (dbind-ex
      (procedure: (symbols body) -> nested-let-code))
    (dbind-lit
      (procedure: (literals) -> literals-check-code))
    (dbind-len
      (procedure: (length-checks) -> length-check-code))
    (filter
      (procedure: (ok? lst) -> (ok not-ok)))
    (flatten
      (procedure: (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))
    (seq-length
      (procedure: (seq) -> generic-length))
    (seq-ref
      (procedure: (seq k) -> generic-kth-item))
    (seq-tail
      (procedure: (seq k) -> generic-kth-rest))
    (seq-length-ref-tail!
      (procedure: (type? type-length type-ref type-tail)
                  updates (seq-length seq-ref seq-tail)))
    (prefixed-with?
      (procedure: (prefix) -> (procedure id)))
    (strip-prefix
      (procedure: (prefix id) -> new-id))
    (strip-suffix
      (procedure: (suffix id) -> new-id))
    (extract
      (procedure: (ok? tree) -> lst))
    (adjoin
      (procedure: (obj lst) -> new-lst))
    (remove-duplicates
      (procedure: (lst) -> new-lst))
    (substitute*
      (procedure: (old new tree) -> new-tree))
    )))

(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)
  (or (list? xpr) (not (pair? 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)))
     (signal (bind-exception 'plist-tail
                             "out of range"
                             pl n)))
    ((zero? n) pl)
    (else
     (plist-tail (cdr pl) (- n 1)))))

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

;;;; 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 (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 (substitute* old new tree)
  (let loop ((tree tree))
    (cond
      ((pair? tree)
       (cons (loop (car tree))
             (loop (cdr tree))))
      ((null? tree) tree)
      ((and (symbol? tree) (eq? tree old)) new)
      (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 (flatten tree)
  (let loop ((tree tree) (result '()))
    (cond
      ((null? tree) result)
      ((not (pair? tree)) (cons tree result))
      (else
        (loop (car tree) (loop (cdr tree) result))))))

(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)))

#|[
Graham's implementation of dbind, cf. On Lisp, p. 232,

(define-syntax dbind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form))
            (seq (caddr form))
            (xpr (cadddr form))
            (xprs (cddddr form))
            (gseq (gensym)))
        `(let ((,gseq ,seq))
           ,(dbind-ex (destruc pat gseq) xpr . xprs))))))

uses the following two helpers, destruc and dbind-ex. 

(define (destruc 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)))))))

(define (dbind-ex binds body)
  (define (mappend fn lists)
    (apply append (map fn lists)))
  (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))))

They are quite simple, but we'll have to modify them by two reasons.
First, they don't check seq's length. So (dbind (a) '(1 2) a) will
happily return 1 without complaining. This might be ok for dbind itself
and bind, but it will cause problems for bind-case.
Second, it can't cope with literals. So (dbind (a "a") '(1 "a") a)
would fail because (let (("a" 1)) ...) fails miserably.
Again, literals are not really needed in dbind and bind, but in
bind-case and macro-rules they are essential.
To cope with these problems, the version of destruc below will
return three values, each of which is handled by its own  routine,
dbind-ex, dbind-lit and dbind-len respectively.
Another addition to dbind is to allow for fenders: The first
expression in the body can impose restrictions on the bound
identifiers.
Graham uses in his Lisp implementation sequences instead of pseudolists.
Scheme does not have them natively, so we restrict ourself in this
module to the latter, which is sufficient for low-level macros.
But in other modules (e.g. bindings) it might be interesting to
destructure generic sequences. This will be done with the second
version of destruc. 
]|#

(define destruc
  (case-lambda
    ((pat seq)
     (destruc pat seq 'plength 'plist-ref 'plist-tail))
     ;(destruc pat seq plength plist-ref plist-tail))
    ((pat seq glen 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 (pair? p)
             (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 (substitute* g 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))))))
           (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)))))))))))


;; 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)
  `(and ,@length-checks))

;;; 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?
                  (lambda (seq n)
                    (if (or (negative? n) (> n (vector-length seq)))
                      (signal (bind-exception 'vector-ref
                                              "out of range"
                                              n seq))
                      (vector-ref seq n))))
            (cons string?
                  (lambda (seq n)
                    (if (or (negative? n) (> n (string-length seq)))
                      (signal (bind-exception 'string-ref
                                              "out of range"
                                              n seq))
                      (string-ref seq n))))
            ;; 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)
  (let* ((len (vector-length seq))
         (vec (make-vector (- len n) #f)))
    (do ((k n (+ k 1)))
      ((= k len) vec)
      (vector-set! vec (- k n) (vector-ref seq k)))))
    
(define-values (seq-tail seq-tail!)
  (let ((table
          (list
            (cons vector?
                  (lambda (seq n)
                    (if (or (negative? n) (> n (vector-length seq)))
                      (signal (bind-exception 'vector-tail
                                              "out of range"
                                              n seq))
                      (vector-tail seq n))))
            (cons string?
                  (lambda (seq n)
                    (if (or (negative? n) (> n (string-length seq)))
                      (signal (bind-exception 'string-tail
                                              "out of range"
                                              n seq))
                      (substring seq n))))
            ;; must be last, because plist? is always #t
            (cons plist? plist-tail))))
    (values
      (search-and-call table)
      (add-to-table table))))

#|[ 
Instead of exporting the three mutators above we export the following
one which updates all three local tables of the accessors in one go.
This way it's impossible to forget updating one of the three tables.
]|#

;;; (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 macro-helpers

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

(module low-level-macros
  (export low-level-macros bind bind-case
          macro-rules define-macro let-macro letrec-macro
          once-only with-gensyms define-syntax-rule)
  (import scheme
          (only macro-helpers bind-exception symbol-dispatcher)
          (only chicken
                condition-case
                print
                current-exception-handler
                make-property-condition
                condition-predicate
                get-condition-property
                signal
                abort))
  (reexport (only macro-helpers ;bind-exception
                  plength plist-ref plist-tail))

  (import-for-syntax (only macro-helpers
                           extract; plength plist-tail plist-ref
                           prefixed-with? strip-prefix
                           destruc dbind-len dbind-lit dbind-ex)
                     (only chicken
                           receive condition-case))

(define low-level-macros
  (symbol-dispatcher '(
    (bind
      macro:
      (_ pat plist (where . fenders) .. xpr ....)
      "binds pattern variables of pat"
      "to corresponding values of plist"
      "checking matching literals and fenders"
      "and executes xpr .... in this context")
    (bind-case
      macro: (_ plist (pat (where . fenders) .. xpr ....) ...)
      "executes"
      "(bind pat plist (where . fenders) ..) xpr ....) ..."
      "in a case fashion")
    (macro-rules
      macro:
      (_ literal ... (keyword ...) (pat tpl) ....)
      "low-level version of syntax-rules with quasiquoted templates")
    (define-macro
      macro:
      one-of
      (_ (name . args) xpr ....)
      (_ (name . args) (with-keywords (x ...) xpr ....))
      (_ (name . args) (with-rename-prefix pre xpr ....))
      (_ (name . args) (with-inject-prefix pre xpr ....))
      (_ (name . args) (with-rename-prefix pre
                         (with-keywords (x ...) xpr ....)))
      (_ (name . args) (with-inject-prefix pre
                         (with-keywords (x ...) xpr ....)))
      "explicit or implicit renaming macro depending on the prefix clause")
    (let-macro
      macro:
      (_ ((code tpl) ...) xpr ....) 
      "local parallel version of define-macro")
    (letrec-macro
      macro:
      (_ ((code tpl) ...) xpr ....) 
      "local recursive version of define-macro")
    (once-only
      macro:
      (_ (x ....) xpr ....)
      "arguments x ... are evaluated only once")
    (with-gensyms
      macro:
      (_ (x ....) xpr ....)
      "generates a series of gensyms x .... to be used in xpr ...")
    (define-syntax-rule
      macro:
      (_ (name . args) xpr ....)
      "syntax-rules with only one rule and without keywords")
    )))


;;; set parameter current-exception-handler to handle 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)))))


#|[
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. This is the reason, why we needed an additional helper, dbind-lit
besides dbind-ex as well as a destruc, which returns two values.
Since Graham's code doesn't check the length of the seq argument, still
another helper is used, matchable?
]|#

(define-syntax dbind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form))
            (seq (caddr form))
            (body (cdddr form))
            (gseq (gensym 'seq)))
        `(let ((,gseq ,seq))
           ,(receive (symbols literals checks)
              (destruc pat gseq)
              `(if ,(dbind-len checks)
                 (if ,(dbind-lit literals)
                   ,(dbind-ex symbols body)
                   (signal
                     (bind-exception 'dbind
                                     "literals don't match"
                                     ',literals)))
                 (signal (bind-exception 'dbind
                                         "not matchable"
                                         ',pat ,gseq)))))))))
;           ,(call-with-values
;              (lambda () (destruc pat gseq))
;              (lambda (symbols literals checks)
;                `(if ,(dbind-len checks)
;                   (if ,(dbind-lit literals)
;                     ,(dbind-ex symbols body)
;                     (signal
;                       (bind-exception 'dbind
;                                       "literals don't match"
;                                       ',literals)))
;                   (signal (bind-exception 'dbind
;                                           "not matchable"
;                                           ',pat ,gseq))))))))))

#|[
The following two macros are simplyfied versions of equally named macros
from the bindings module, restricting sequences to lists and
pseudolists. This is sufficient for destructuring macro-arguments.
The first is a variant of Common Lisp's destructuring-bind.
]|#

;;; (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))))

;; old version which doesn't handle match of literals
;(define-syntax bind
;  (syntax-rules (where)
;    ((_ pat seq (where . fenders) xpr . xprs)
;     (bind pat seq
;       (if (and . fenders)
;         (begin xpr . xprs)
;         (signal (bind-exception pat seq . fenders)))))
;    ((_ (a . b) seq xpr . xprs)
;     (let ((seq1 seq))
;       (if (pair? seq1)
;         (bind a (car seq1)
;           (bind b (cdr seq1) xpr . xprs))
;         (signal (bind-exception (a . b) seq1)))))
;    ((_ () seq xpr . xprs)
;     (let ((seq1 seq))
;       (if (null? seq1)
;         (let () xpr . xprs)
;         (signal (bind-exception () seq1)))))
;    ((_ a seq xpr . xprs)
;     (let ((seq1 seq))
;       (let ((a seq1)) 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 (dbind pat seq (and . fenders) xpr . xprs)
     ;(condition-case (bind pat seq (where . fenders) xpr . xprs)
       ((exn bind) (bind-case seq . clauses))))
    ((_ seq (pat xpr . xprs) . clauses)
     (condition-case (dbind pat seq #t xpr . xprs)
     ;(condition-case (bind pat seq xpr . xprs)
       ((exn bind) (bind-case seq . clauses))))
    ((_ seq)
     (signal (bind-exception 'bind-case
                             "no rule matches"
                             seq)))
    ))

;;; (define-macro (name . args)
;;;   [(with-inject-prefix pre | (with-rename-prefix pre)]
;;;     [(with-keywords (x y ...)]
;;;       . body)))
;;; ------------------------------------------------------
(define-syntax define-macro
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((pat (cadr f)) (body (caddr f)))
        (let (
          (type (cond ((c? (car body) 'with-rename-prefix) 'er)
                      ((c? (car body) 'with-inject-prefix) 'ir)
                      (else 'no)))
          )
          (let (
            (transformer (case type
                           ((er) 'er-macro-transformer)
                           (else 'ir-macro-transformer)))
            (rename-or-inject (case type
                                ((er) 'rename)
                                (else 'inject)))
            (body (case type
                    ((no) body)
                    (else (caddr body))))
            (pre (case type
                   ((no) #f)
                   (else (cadr body))))
            (process
              (lambda (p keys)
                (map (lambda (x y) `(compare? ,x ,y))
                     (extract (lambda (a) (memq a keys)) (cdr p))
                     (map (lambda (b) `',b)
                          (extract (lambda (a) (memq a keys)) (cdr p))))))
            )
            (let ((keywords? (c? (car body) 'with-keywords)))
              (cond
                ((and pre keywords?)
                 (let ((keywords (cadr body)) (body (caddr body)))
                   `(define-syntax ,(car pat)
                      (,transformer
                        (lambda (form ,rename-or-inject compare?)
                          (condition-case
                            (dbind ,(cdr pat) (cdr form)
                              (and ,@(process (cdr pat) keywords))
                              (let ,(map (lambda (s)
                                           `(,s (,rename-or-inject
                                                  ',(strip-prefix (i pre)
                                                                  (i s)))))
                                         (extract (prefixed-with? (i pre))
                                                  body))
                                ,body))
                            ((exn bind)
                             (signal (bind-exception 'define-macro
                                                     "no match")))))))))
                (pre
                 `(define-syntax ,(car pat)
                    (,transformer
                      (lambda (form ,rename-or-inject compare?)
                        (condition-case
                          (dbind ,(cdr pat) (cdr form)
                            #t
                            (let ,(map (lambda (s)
                                         `(,s (,rename-or-inject
                                                ',(strip-prefix (i pre)
                                                                (i s)))))
                                       (extract (prefixed-with? (i pre))
                                                body))
                              ,body))
                          ((exn bind)
                           (signal (bind-exception 'define-macro
                                                   "no match"))))))))
                (keywords?
                 (let ((keywords (cadr body)) (body (caddr body)))
                   `(define-syntax ,(car pat)
                      (ir-macro-transformer
                        (lambda (form inject compare?)
                          (condition-case
                            (dbind ,(cdr pat) (cdr form)
                              (and ,@(process (cdr pat) keywords))
                              ,body)
                            ((exn bind)
                             (signal (bind-exception 'define-macro
                                                     "no match")))))))))
                (else
                 `(define-syntax ,(car pat)
                    (ir-macro-transformer
                      (lambda (form inject compare?)
                        (condition-case
                          (dbind ,(cdr pat) (cdr form)
                            #t
                            ,body)
                          ((exn bind)
                           (signal (bind-exception 'define-macro
                                                   "no match"))))))))))))))))

;;; (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)))))

;;; (macro-rules sym ... (keyword ...)
;;;   (pat0 tpl0) (pat1 tpl1) ...)
;;; ----------------------------------
;;; where sym ... are injected non-hygienig symbols, keyword ... are
;;; additionl keywords, pat0 pat1 ...  are nested lambda-lists without
;;; spezial meaning of ellipses and tpl0 tpl1 ... evaluate to
;;; quasiquoted templates.
(define-syntax macro-rules
  (ir-macro-transformer
    (lambda (f i c?)
      ;; head is list of injected syms, tail starts with keyword-list
      (receive (tail head)
        (let loop ((tail (cdr f)) (head '()))
          (if (list? (car tail)) ; keyword list
            (values tail head)
            (loop (cdr tail) (cons (car tail) head))))
          (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* (
                (extract-keywords
                  (lambda (r) (extract (lambda (y) (memq y keywords)) r)))
                (process-rule ;;; bind-case
                  (lambda (r)
                    `(,(car r)
                       (where ,@(map (lambda (p s) `(compare? ,p ,s))
                                     (extract-keywords (cadar r)) ;(cdr r)(cadar r)
                                     (map (lambda (x) `',x)
                                          (extract-keywords (cadar r)))))
                       ,(cadr r))))
                )
                (cond
                  ((and (null? head) (null? keywords))
                   ; no injected symbols, no additional keywords
                   `(ir-macro-transformer
                      (lambda (form inject compare?)
                        (bind-case form ,@rules))))
                  ((null? head)
                   ; no injected symbols
                   `(ir-macro-transformer
                      (lambda (form inject compare?)
                        (bind-case form
                          ,@(map process-rule rules)))))
                  ((null? keywords)
                   ;; no additional keywords
                   `(ir-macro-transformer
                      (lambda (form inject compare?)
                        (let ,(map inject-sym head)
                          (bind-case form ,@rules)))))
                  (else ; both injected symbols and additional keywords
                    `(ir-macro-transformer
                       (lambda (form inject compare?)
                         (let ,(map inject-sym head)
                           (bind-case form
                             ,@(map process-rule rules))))))))))))))

#|[
The following three macros are here for convenience. The first two are
of great help in writing low-level-macros, the last ony simplifies
high-level macros without additional keywords and only one rule - it's
defined in miscmacros as well.
]|#

;;; (once-only (x ...) . body)
;;; --------------------------
;;; macro-arguments x ... are only evaluated once and from left to right
(define-syntax once-only  ; ok
  (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))))))))

;;; (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)))))

;;; (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))))))

) ; module low-level-macros

;(use simple-tests tuples)
;(import macro-helpers low-level-macros)
;(import-for-syntax (only low-level-macros macro-rules bind-case))
;(import-for-syntax (only macro-helpers seq-length seq-ref seq-tail))