; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2013-2018, 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 dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser 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.


#|[

The fundamental macro defined in this library is bind. It's like
destructuring-bind in Common Lisp and dbind in Graham's classic On Lisp,
but with some extensions, in particular, wildcards, non-symbol literals
and fenders.

The syntax is as follows

  (bind pat seq [(where . fenders)] . body)

It destructures the seq argument according to the pat argument, binds
pattern variables to corresponding sequence items and executes body in
this context. For example

  (bind (x (y z) . w) '(1 #(2 3) 4 5) (where (y even?)) (list x y z w))

will return '(1 2 3 (4 5)).

(Note that the position of the optional fenders, supplied in a where
clause, has changed again in this version: It's now always on top of the body.
This simplyfies implementation and usage of the library).

This version of the library is a complete rewrite. The code no longer
uses Graham's dbind implementation. Instead, a direct implementation of
bind is given, which doesn't need gensyms. The internal destructure
routine transforms the pattern and sequence arguments into three lists,
pairs, literals and tails. Pairs is a list of pattern-variable and
corresponding sequence-accesscode pairs to be used in a let at runtime,
literals and tails check for equality of literals and their
corresponding sequence values, and the emptyness of sequence tails
corresponding to null patterns respectively. So, contrary to Graham's
dbind, an exception is raised if the lengths of a pattern and its
corresponding sequence don't match. Fenders are supplied in a where
clause at the very beginning of the macro body: A list of
pattern-variable predicates pairs is internally transformed into a list
of predicate calls.

Sequences are either lists, psuedolists, vectors or strings by default.
The sequence operators needed are bind-seq-ref, bind-seq-tail and bind-seq-null? with
the same syntax as the likely named list routines.  But there is a
procedure, bind-seq-db, which allows to add a pair consisting of a type
predicate and a vector containing the needed operators to a database.

]|#

(module bindings
  (bind bind-case bind-lambda bind-lambda* bind-case-lambda
   bind-case-lambda* bind-named bind-let bind-let* bind-letrec bindrec
   bindable? bind-define bind-set! bind/cc bindings bind-seq-db
	 bind-seq-ref bind-seq-tail bind-seq-null? bind-seq-exception
	 bind-pseudo-list?)

  (import scheme
          (only (chicken base)
                case-lambda receive error assert define-inline
                subvector chop print)
          (only (chicken condition) condition-case)
          (only (chicken fixnum) fx+ fx- fx= fx>=)
          (only simple-exceptions make-exception raise)
          )
  (import-for-syntax (only (chicken base) receive chop)
                     (only (chicken keyword) keyword?))

;;; exceptions
;;; ----------
(define bind-seq-exception
  (make-exception "sequence exception" 'sequence))

;;; helpers
;;; -------
(define-inline (1+ n) (fx+ n 1))
(define-inline (1- n) (fx- n 1))
(define-inline (0= n) (fx= n 0))
(define-inline (0<= n) (fx>= n 0))

(define (bind-pseudo-list? xpr) #t)

;;; (bind-seq-ref seq k)
;;; ---------------
;;; access to a sequence item
;;; the second returned value is needed in bind-seq-null?
(define (bind-seq-ref seq k)
  (assert (0<= k) 'bind-seq-ref)
  (values
    (let loop ((db (bind-seq-db)))
      ;; Since everything is a bind-pseudo-list, which is checked last
      ;; db is never empty
      (if ((caar db) seq)
        ((vector-ref (cdar db) 0) seq k)
        (loop (cdr db))))
    #f))

;;; (bind-seq-tail seq k)
;;; ----------------
;;; access to the tail of a sequence
(define (bind-seq-tail seq k)
  (assert (0<= k) 'bind-seq-tail)
  (let loop ((db (bind-seq-db)))
    ;; Since everything is a bind-pseudo-list, which is checked last
    ;; db is never empty
    (if ((caar db) seq)
      ((vector-ref (cdar db) 1) seq k)
      (loop (cdr db)))))

;;; (bind-seq-null? seq)
;;; ---------------
;;; tests for emptiness of a sequence
(define (bind-seq-null? seq)
  (receive (result out-of-bounds?)
    (condition-case (bind-seq-ref seq 0)
      ((exn) (values #t #t)))
    (if out-of-bounds? #t #f)))

;;; (bind-seq-db type? ref: ref tail: tail)
;;; ---------------------------------
;;; adds a new sequence type to the front of the database
;;; (bind-seq-db)
;;; --------
;;; shows the sequence database
(define bind-seq-db
  (let ((db (list (cons list? (vector list-ref list-tail))
                  (cons vector? (vector vector-ref subvector))
                  (cons string? (vector string-ref substring))
                  (cons bind-pseudo-list? 
                        (vector (lambda (pl k) ; ref
                                  (let loop ((pl pl) (n 0))
                                    (cond
                                      ((and (pair? pl) (fx= n k))
                                       (car pl))
                                      ((pair? pl)
                                       (loop (cdr pl) (1+ n)))
                                      (else
                                        (raise (bind-seq-exception 'bind-seq-ref
                                                              "out of range"
                                                              pl k))))))
                                (lambda (pl k) ; tail  ;;; wrong at end
                                  (let loop ((pl pl) (n 0))
                                    (cond
                                      ((fx= n k)
                                       pl)
                                      ((pair? pl)
                                       (loop (cdr pl) (1+ n)))
                                      (else
                                        (raise (bind-seq-exception 'bind-seq-tail
                                                              "out of range"
                                                              pl k))))))
                                ))
                  )))
    (case-lambda
      (() db)
      ((type? . keyword-args)
       (let* ((args (chop keyword-args 2))
              (vec (make-vector (length args))))
         ;; populate vec and add to db
         (do ((args args (cdr args)))
           ((null? args)
            (set! db
                  (cons (cons type? vec) db)))
           (case (caar args)
             ((#:ref)
              (vector-set! vec
                           0
                           (lambda (seq k)
                             (condition-case
                               ((cadar args) seq k)
                               ((exn)
                                (raise (bind-seq-exception 'bind-seq-ref
                                                      "out of range"
                                                      seq k)))))))
             ((#:tail)
              (vector-set! vec
                           1
                           (lambda (seq k)
                             (condition-case
                               ((cadar args) seq k)
                               ((exn)
                                (raise (bind-seq-exception 'bind-seq-tail
                                                      "out of range"
                                                      seq k)))))))
             (else
               (raise (bind-seq-exception 'bind-seq-db
                                     "not a keyword"
                                     (caar args))))
             )))))))

;;; simple explicit-renaming  macros
;;; ---------------------------------
(define-syntax define-er-macro-transformer
  (syntax-rules ()
    ((_ (name form rename compare?) xpr . xprs)
     (define-syntax name
       (er-macro-transformer
         (lambda (form rename compare?) xpr . xprs))))))

#|[
First, a helper macro, which allows to implement bind as well
as a recursive version of it, bindrec, in one go.
It does all of the dirty work,
]|#

;;; (bind-with binder pat seq xpr . xprs)
;;; -------------------------------------
;;; where binder is let or letrec
(define-er-macro-transformer (bind-with form rename compare?)
  (let ((binder (cadr form))
        (pat (caddr form))
        (seq (cadddr form))
        (xpr (car (cddddr form)))
        (xprs (cdr (cddddr form)))
        (%and (rename 'and))
        (%where (rename 'where))
        (%_ (rename '_))
        (%if (rename 'if))
        (%raise (rename 'raise))
        (%begin (rename 'begin))
        (%error (rename 'error))
        (%equal? (rename 'equal?))
        (%bind-seq-ref (rename 'bind-seq-ref))
        (%bind-seq-tail (rename 'bind-seq-tail))
        (%bind-seq-null? (rename 'bind-seq-null?))
        (%bind-seq-exception (rename 'bind-seq-exception)))
    (let* ((fenders? (and (pair? xpr)
                        (compare? (car xpr) %where)))
           (where-clause (if fenders? 
                             xpr                 
                             '(where)))
           (fenders
             (apply append
                    (map (lambda (pair)
                           (map (lambda (p?)
                                  `(,p?  ,(car pair)))
                                (cdr pair)))
                         (cdr where-clause))))
           (body (if fenders?
                   `(,%if (,%and ,@fenders)
                      (,%begin ,@xprs)
                      (,%raise (,%bind-seq-exception
                                 'bind
                                 "fenders not passed"
                                 ',fenders)))
                   `(,%begin ,xpr ,@xprs))))
      (letrec (
        (no-dups?
          (lambda (lst)
            (call-with-current-continuation
              (lambda (cc)
                (let loop ((lst lst) (result '()))
                  (if (null? lst)
                    #t
                    (loop (cdr lst)
                          ;(if (memq (car lst) result)
                          ;; keywords can be used as literals
                          (if (and (not (keyword? (car lst)))
                                   (memq (car lst) result))
                            (cc #f)
                            (cons (car lst) result)))))))))
        (destructure
           (lambda (pat seq)
             (let ((len (let loop ((pat pat) (result 0))
                          (cond
                            ((null? pat) result)
                            ((pair? pat)
                             (loop (cdr pat) (+ 1 result)))
                            (else result)))))
               (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
                 (if (= k len)
                   (let ((sentinel
                           ;last dotted item or '()
                           (let loop ((result pat) (k len))
                             (if (zero? k)
                               result
                               (loop (cdr result) (- k 1))))))
                     (cond
                       ((null? sentinel)
                        (values pairs literals
                                (cons `(,%bind-seq-null?
                                         (,%bind-seq-tail ,seq ,k))
                                      tails)))
                       ((symbol? sentinel)
                        (if (compare? sentinel %_)
                          (values pairs literals tails)
                          (values (cons (list sentinel
                                              `(,%bind-seq-tail ,seq ,k))
                                        pairs)
                                  literals tails)))
                       (else
                         (values pairs
                                 (cons `(,%equal? ',sentinel
                                                  (,%bind-seq-tail ,seq ,k))
                                       literals)
                                 tails))))
                   (let ((item (list-ref pat k)))
                     (cond
                       ;((symbol? item)
                       ((and (symbol? item) (not (keyword? item)))
                        (if (compare? item %_)
                          (loop (+ k 1) pairs literals tails)
                          (loop (+ k 1)
                                (cons (list item `(,%bind-seq-ref ,seq ,k)) pairs)
                                literals
                                tails)))
                       ;((atom? item) ; literal 
											 ((and (not (pair? item)) (not (null? item)))
                        (loop (+ k 1)
                              pairs
                              (cons `(,%equal? ',item
                                               (,%bind-seq-ref ,seq ,k))
                                    literals)
                              tails))
                       ;((pair? item)
											 ((or (null? item) (pair? item))
                        (receive (ps ls ts)
                          (destructure item `(,%bind-seq-ref ,seq ,k))
                          (loop (+ k 1)
                                (append ps pairs)
                                (append ls literals)
                                (append ts tails))))
                       )))))))
        )
        (receive (pairs literals tails)
          (destructure pat seq)
          (if (no-dups? (map car pairs))
            `(,%if (,%and ,@tails)
               (,%if (,%and ,@literals)
                 (,(rename binder) ,pairs ,body)
                 (,%raise (,%bind-seq-exception
                            'bind
                            "literals don't match"
                            ',literals)))
               (,%raise (,%bind-seq-exception
                          'bind
                          "length mismatch"
                          ',tails)))
            `(,%error 'bind-with
                      "duplicate pattern variables"
                      ',(map car pairs))
          ))))))

#|[
The following is Graham's dbind extended with fenders, wildcards,
non-symbol literals and length-checks. For example

  (bind (x (y z)) '(1 #(2 3)) (where (x integer?)) (list x y z))

will result in '(1 2 3) while

  (bind (_ ("y" z)) '(1 #("y" z)) z)

will produce 3.
]|#

;;; (bind pat seq (where . fenders) .. xpr ....)
;;; ---------------------------------------------
;;; binds pattern variables of pat to corresponding subexpressions of
;;; seq and executes body xpr .... in this context, provided all
;;; fenders pass
(define-er-macro-transformer (bind form rename compare?)
  (let ((pat (cadr form))
        (seq (caddr form))
        (xpr (cadddr form))
        (xprs (cddddr form))
        (%let (rename 'let))
        (%where (rename 'where))
        (%bind-with (rename 'bind-with))
        (%seq (rename 'seq)))
    (let ((fenders? (and (pair? xpr) (compare? (car xpr) %where))))
      (let ((body (if fenders?
                     `(,xpr ,@xprs)
                     `((,%where) ,xpr ,@xprs))))
        `(,%let ((,%seq ,seq))
           ;,(cons %bind-with
           ;       (cons %let
           ;             (cons pat
           ;                   (cons %seq body)))))))))
					 ,(apply list %bind-with %let pat %seq body))))))

#|[
And here is the recursive version of bind, which is used in bind-letrec.

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

;;; (bindrec pat seq (where fender ...) .. xpr ....)
;;; ------------------------------------------------
;;; recursive version of bind
(define-syntax bindrec
  (syntax-rules ()
    ((_ pat seq xpr . xprs)
     (bind-with letrec pat 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 (y list?)) (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 fender ...) .. xpr ....) ....)
;;; ---------------------------------------------------------
;;; Checks if seq matches pattern pat [satisfying fender ...] ....
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; corresponding body xpr ....
(define-syntax bind-case
  (ir-macro-transformer
    (lambda (form inject compare?)
  (let ((seq (cadr form))
        (rules (cddr form))
        (insert-where-clause
          (lambda (rule)
            (if (and (pair? (cadr rule))
                     (compare? (caadr rule) 'where))
              rule
              `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
    (let ((rules (map insert-where-clause rules))
          (rule->bind
            (lambda (rule)
              `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
      (let loop ((binds (map rule->bind rules)) (pats '()))
        (if (null? binds)
           `(raise (bind-seq-exception 'bind-case "no match"
                                  ,seq
                                  ',(reverse pats)))
           `(condition-case ,(car binds)
              ((exn)
               ,(loop (cdr binds)
                      (cons (list (cadar binds) (car (cdddar binds)))
                            pats)))))))))))
; the procedural version above improves the error message
;(define-syntax bind-case
;  (syntax-rules ()
;    ((_ seq)
;     (raise (bind-seq-exception 'bind-case "no match for" seq)))
;    ((_ seq (pat (where . fenders) xpr . xprs))
;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
;       ((exn sequence) (bind-case seq))))
;    ((_ seq (pat xpr . xprs))
;     (bind-case seq (pat (where) xpr . xprs)))
;    ((_ seq clause . clauses)
;     (condition-case (bind-case seq clause)
;       ((exn sequence) (bind-case seq . clauses))))
;    ))

#|[
The next macro, bindable?, can be used to check, if a
sequence-expression matches a pattern and passes all fenders.
]|#

;;; (bindable? pat (where fender ...) ..)
;;; -------------------------------------
;;; returns a unary predicate which checks, if its argument matches pat
;;; and fulfills the predicates in the list fender ...
;;; Mostly used in fenders of macro-rules and define-macro-transformer, but must
;;; then be imported for-syntax.
(define-syntax bindable?
  (syntax-rules (where)
    ((_ pat (where . fenders))
     (lambda (seq)
        (condition-case (bind pat seq (where . fenders) #t)
          ((exn sequence) #f))))
    ((_ pat)
     (bindable? pat (where)))))

#|[ 
The following two macros, bind-define and bind-set!, destructure their
sequence arguments with respect to their pattern argument and define or
set! the pattern variables correspondingly.  For example, one can define
multiple procedures operating on a common state

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

]|#

;;; (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
;;; -------------------------------------------------------
;;; sets pattern variables of pat pat1 ... to corresponding sub-expressins of
;;; seq seq1 ..., provided the fenders are satisfied
(define-er-macro-transformer (bind-set! form rename compare?)
  (let ((pairs (reverse (chop (cdr form) 2)))
        (%_ (rename '_))
        (%let (rename 'let))
        (%list (rename 'list))
        (%where (rename 'where))
        (%bind (rename 'bind))
        (%set! (rename 'set!))
        (%seq (rename 'seq)))
    (let ((where-clause?
            (and (null? (cdar pairs))
                 (pair? (caar pairs))
                 (compare? (caaar pairs) %where))))
      (let ((where-clause (if where-clause?
                            (caar pairs)
                            `(,%where)))
            (pairs (if where-clause?
                     ;(reverse (cdr pairs))
                     (cdr pairs)
                     ;(reverse pairs))))
                     pairs)))
        (let ((pat (map car pairs))
              (seq `(,%list ,@(map cadr pairs)))
              (sym? (lambda (x)
                      (and (symbol? x)
                           (not (compare? x %_))))))
    (letrec (
      (pflatten (lambda (pls)
                  (cond
                    ((null? pls) pls)
                    ((pair? pls)
                     (append (pflatten (car pls))
                             (pflatten (cdr pls))))
                    (else (list pls)))))
      (filter (lambda (ok? lst)
                 (compress (map ok? lst) lst)))
      (reduce (lambda (pat)
                 (filter sym? (pflatten pat))))
      )
      (let ((aux (let copy ((pat pat))
                    (cond
                      ((sym? pat) (rename pat))
                      ((pair? pat)
                       (cons (copy (car pat)) (copy (cdr pat))))
                      (else pat))))
            (%where-clause
              (cons %where
                    (map (lambda (c)
                           (cons (rename (car c))
                                 (cdr c)))
                         (cdr where-clause)))))
        `(,%let ((,%seq ,seq))
           (,%bind ,aux ,%seq ,%where-clause
                   ,@(map (lambda (p a) `(,%set! ,p ,a))
                          (reduce pat)
                          (reduce aux))))
        )))))))

;;; (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
;;; ---------------------------------------------------------
;;; destructures the sequences seq seq1 ... according to the patterns
;;; pat pat1 ...  and sets pattern variables with values corresponding
;;; to subexpressions of seq seq1 ..., provided the fenders are
;;; satisfied
(define-er-macro-transformer (bind-define form rename compare?)
  (let ((pairs (reverse (chop (cdr form) 2)))
        (%_ (rename '_))
        (%list (rename 'list))
        (%where (rename 'where))
        (%bind-set! (rename 'bind-set!))
        (%define (rename 'define))
        (%begin (rename 'begin)))
    (let ((where-clause?
            (and (null? (cdar pairs))
                 (pair? (caar pairs))
                 (compare? (caaar pairs) %where))))
      (let ((where-clause (if where-clause?
                            (caar pairs)
                            `(,%where)))
            (pairs (if where-clause?
                     ;(reverse (cdr pairs))
                     (cdr pairs)
                     ;(reverse pairs))))
                     pairs)))
        (let ((pat (map car pairs))
              (seq `(,%list ,@(map cadr pairs)))
              (sym? (lambda (x)
                      (and (symbol? x)
                           (not (compare? x %_))))))
    (letrec (
      (map-flatten (lambda (pls)
                     (cond
                       ((null? pls) pls)
                       ((pair? pls)
                        (append (map-flatten (car pls))
                                (map-flatten (cdr pls))))
                       (else (list `(,%define ,pls #f))))))
      (filter (lambda (ok? lst)
                (compress (map ok? lst) lst)))
      )
      `(,%begin
         ,@(filter sym?
                   (map-flatten pat))
         (,%bind-set! ,pat ,seq ,where-clause))))))))

#|[
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 (where fender ...) .. xpr ....)
;;; ------------------------------------------------
;;; 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)
     (bind-lambda pat (where) xpr . xprs))))

;;; (bind-lambda* pat (where fender ...) .. xpr ....)
;;; -------------------------------------------------
;;; 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)
     (bind-lambda* pat (where) xpr . xprs))))

#|[ 
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 (e zero?)) 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 fender ...) .. xpr ....) ....)
;;; ------------------------------------------------------------
;;; 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-case x (pat (where . fenders) xpr . xprs))))
    ((_ (pat xpr . xprs))
     (lambda (x)
       (bind-case x (pat xpr . xprs))))
    ((_ clause . clauses)
     (lambda (x)
       (bind-case x clause . clauses)))))

;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
;;; -------------------------------------------------------------
;;; 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-case x (pat (where . fenders) xpr . xprs))))
    ((_ (pat xpr . xprs))
     (lambda x
       (bind-case x (pat xpr . xprs))))
    ((_ clause . clauses)
     (lambda x
       (bind-case x clause . clauses)))))

#|[
The following macro, bind-named, 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-named loop (x y) '(5 0)
    (if (zero? x)
      (list x y)
      (loop (list (sub1 x) (add1 y)))))
  -> '(0 5)
]|#

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

#|[
Now the implementation of a nested version of let, named and unnamed,
is easy: Simply combine bind and bind-named. 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)))))
      ;(loop (list (list (sub1 a) (add1 b))))))
      ;version with bind-named
  -> '(0 5)
]|#

;;; (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
;;; -----------------------------------------------------------------
;;; nested version of let, named and unnamed
(define-er-macro-transformer (bind-let form rename compare?)
  (let ((named? (symbol? (cadr form))))
    (let ((name (if named? (cadr form) (gensym)))
          (binds (if named? (caddr form) (cadr form)))
          (xpr (if named? (cadddr form) (caddr form)))
          (xprs (if named? (cddddr form) (cdddr form))))
      (let ((pats (map car binds))
            (seqs (map cadr binds))
            (%list (rename 'list))
            (%bind (rename 'bind))
            ;(%bind-named (rename 'bind-named)))
            (%letrec (rename 'letrec))
            (%bind-lambda* (rename 'bind-lambda*)))
        (if named?
          `(,%letrec ((,name (,%bind-lambda* ,pats ,xpr ,@xprs)))
             (,name ,@seqs))
          ;`(,%bind-named ,name ,pats (,%list ,@seqs) ,xpr ,@xprs)
          `(,%bind ,pats (,%list ,@seqs) ,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) ...) (where fender ...) .. xpr ....)
;;; ----------------------------------------------------------
;;; sequential version of bind-let
(define-syntax bind-let*
  (syntax-rules (where)
    ((_ () xpr . xprs)
     (begin xpr . xprs))
    ((_ ((pat seq)) (where . fenders) xpr . xprs)
     (bind pat seq (where . fenders) xpr . xprs))
    ((_ ((pat seq)) xpr . xprs)
     (bind pat seq xpr . xprs))
    ((_ ((pat seq) binds ...) (where . fenders) xpr . xprs)
     (bind pat seq (bind-let* (binds ...)
                     (where . fenders) xpr . xprs)))
    ((_ ((pat seq) binds ...) xpr . xprs)
     (bind pat seq
       (bind-let* (binds ...) 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) ...) (where fender ...) .. xpr ....)
;;; ------------------------------------------------------------
;;; recursive version of bind-let
(define-er-macro-transformer (bind-letrec form rename compare?)
  (let ((binds (cadr form)) (xpr (caddr form)) (xprs (cdddr form)))
    (let ((pats (map car binds))
          (seqs (map cadr binds))
          (%list (rename 'list))
          (%bindrec (rename 'bindrec)))
      `(,%bindrec ,pats (,%list ,@seqs) ,xpr ,@xprs))))

#|[ 
The following macro is sometimes named let/cc or let-cc
]|#

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


;;; (symbol-dispatcher alist)
;;; -------------------------
;;; returns a procedure of zero or one argument, which shows all cars
;;; or the cdr of the alist item with car symbol
(define (symbol-dispatcher alist)
  (case-lambda
    (()
     (map car alist))
    ((sym)
     (let ((pair (assq sym alist)))
       (if pair
         (for-each print (cdr pair))
         (error "Not in list"
                sym
                (map car alist)))))))

;;; (bindings sym ..)
;;; ----------------------
;;; documentation procedure
(define bindings
  (symbol-dispatcher '(
    (bindings
      procedure:
      (bindings sym ..)
      "documentation procedure")
    (bind-seq-exception
      procedure:
      (bind-seq-exception loc . args)
      "generates an exception to be raised")
    (bind-seq-db
      procedure:
      (bind-seq-db)
      "shows the sequence database"
      (bind-seq-db type ref: ref tail: tail)
      "adds a new sequence type to the database where the keywords"
      "name arguments being accessed as bind-seq-ref and bind-seq-tail"
      "respectively")
    (bind-seq-ref
      procedure:
      (bind-seq-ref seq k)
      "sequence analog of list-ref")
    (bind-seq-tail
      procedure:
      (bind-seq-tail seq k)
      "sequence analog of list-tail")
    (bind-seq-null?
      procedure:
      (bind-seq-null? xpr)
      "sequence analog of null?")
    (bind-pseudo-list
      procedure:
      (bind-pseudo-list? xpr)
      "always #t")
    (bind
      macro:
      (bind pat seq (where fender ...) .. xpr ....)
      "a variant of Common Lisp's destructuring-bind")
    (bind-case
      macro:
      (bind-case seq (pat (where fender ...) .. xpr ....) ....)
      "matches seq against pat with optional fenders in a case regime")
    (bindable?
      macro:
      (bindable? pat (where fender ...) ..)
      "returns a unary predicate, which checks"
      "if its argument matches pat and passes all fenders")
    (bind-set!
      macro:
      (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
      "sets multiple variables by destructuring its sequence arguments")
    (bind-define
      macro:
      (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
      "defines multiple variables by destructuring its sequence arguments")
    (bind-lambda
      macro:
      (bind-lambda pat (where fender ...) .. xpr ....)
      "combination of lambda and bind, one pattern argument")
    (bind-lambda*
      macro:
      (bind-lambda* pat (where fender ...) .. xpr ....)
      "combination of lambda and bind, multiple pattern arguments")
    (bind-named
      macro:
      (bind-named loop pat (where fender ...) .. seq xpr ....)
      "named version of bind")
    (bind-let
      macro:
      (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
      "nested version of let, named and unnamed")
    (bind-let*
      macro:
      (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
      "nested version of let*")
    (bindrec
      macro:
      (bindrec pat seq (where fender ...) .. xpr ....)
      "recursive version of bind")
    (bind-letrec
      macro:
      (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
      "recursive version of bind-let")
    (bind-case-lambda
      macro:
      (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
      "combination of lambda and bind-case with one pattern argument")
    (bind-case-lambda*
      macro:
      (bind-case-lambda* (pat (where fender ...) .. 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")
    )))
  ) ; bindings

;(import bindings)