;;;; File: bindings.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Oct 24, 2010
;;;;       Oct 28, 2010
;;;;       Nov 02, 2010
;;;;       Nov 04, 2010
;;;;       Nov 09, 2010
;;;;       Nov 26, 2010
;;;;       Nov 28, 2010
;;;;       Jan 19, 2011
;;;;       Jan 25, 2011
;;;;       Jan 31, 2011
;;;;       Feb 04, 2011
;;;;       Feb 12, 2011


;Binding pattern variables to subexpressions
;===========================================
;
;In this module, you'll find macros, which all operate on patterns, that
;is, nested pseudolists of symbols. To be more precise, here is a formal
;definition, which is motivated by the definition of a lambda-list,
;which is the type of the arguments of a lambda expression: A
;lambda-list is either a symbol, the empty list or a pair consisting of
;a symbol and a lambda-list, or - more formally -
;
;lambda-list? :=
;  symbol? | null? | (cons symbol? lambda-list?)
;
;The arguments of macros on the other hand can be more general, namely
;they can be nested. Let's call the appropriate type a pattern, whose
;formal definition is
;
;pattern? :=
;  symbol? | null? | (cons (and pattern? (not null?)) pattern?)
;
;As usual, you'll find the list of exported operators in the header of
;the module definition. They are all macros. The first group consists of
;binding constructs, they bind the symbols of patterns to matching
;subexpressions of nested pseudolists.  The second group contains
;applications to facilitate the writing of explicit renaming macros. 

(require 'contracts)

(module bindings
    (bind-matches? bind-case bind-let bind-let* bind-letrec
    bind bindrec bind-lambda bind-lambda* bind-loop bind-set!
    bind-define bind-case-lambda bind-case-lambda* bind-flat
    bind-flat-let* bindings)

(import scheme 
        (only contracts define-syntax-with-contract doclist
              doclist->dispatcher)
        (only data-structures compress o)
        (only chicken assert void error gensym))

(import-for-syntax (only scheme cddr))

;; initialize doclist with macros without contract
;; hence without automatic documentation
(doclist
  '((bind-set!
      (#:forms (bind-set! pat xpr))
      "set! symbols of pat to corresponding subexpressions of xpr")))


;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 implement bind-define as an alias to bind-set!

;;; (bind-define pat xpr)
;;; ---------------------
;;; defines pattern variables of pat to corresponding subexpressions of xpr
(define-syntax-with-contract bind-define
  "defines pattern variables in one go"
  (syntax-rules ()
    ((_ pat xpr) (bind-set! pat xpr))))

;bind-set! replaces the values of symbols in a nested lambda-list in one
;go with the corresponding subexpressions 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. But the real advantage of this is, that
;we can define several functions which rely on the same state. Consider
;
;  (bind-set! (stack push! pop!)
;    (let ((lst '()))
;      (list
;        (lambda () lst)
;        (lambda (xpr) (set! lst (cons xpr lst)))
;        (lambda () (set! lst (cdr lst))))))
;
;but be sure not to import miscmacros, which defines push! and pop! as
;macros, which would take precedence over identically named procedures.
;Now we have three procedures, which all rely on the encapsulated list
;lst. The same effect could be achieved with
;
;  (bind-set! (stack (push! pop!))
;    (list
;      '()
;      (list
;        (lambda (xpr) (set! stack (cons xpr stack)))
;        (lambda () (set! stack (cdr stack))))))
;
;but now, stack is not read-only: It could be changed from outside by set!
;
;A syntax-rules implementation of bind-set! will be rejected, because it
;traverses its pattern argument depth-first. We want breadth-first
;traversal and parallel settings of symbols in one nesting level
;instead. So we rely on low-level explicit renaming macros and a local
;helper procedure, dissect, to reduce the nested case to the flat case.
;Three other local helper procedures are used as well, pmap1 and pmap2
;to be used in the flat case, and lambda-list? to discriminate between
;the two cases. The former are mapping procedures which work on
;pseudo-lists of symbols, the latter is the canonical predicate.
;
;The use of local helper procedures guarantees, that this
;procedures are available at compile time. Otherwise we had to use
;define-for-syntax, which would export these names behind the scene or
;define them in a helper module and use import-for-syntax. By the way,
;the choice of local functions which are called outside backquotes
;guarantees, that the code is evaluated at compile-time, thus improving
;runtime behaviour. Since bind-set! will do almost all of the work of
;the other exported macros as well, it pays when most of that work is
;done at compile-time!

;;; (bind-set! pat xpr)
;;; -------------------
;;; sets pattern variables of pat to corresponding subexpressions of xpr
(define-syntax bind-set! ; ok!
  (lambda (form rename compare?)
    (let (
      (pat (cadr form))
      (xpr (caddr form))
      (%if (rename 'if))
      (%car (rename 'car))
      (%null? (rename 'null?))
      (%void (rename 'void))
      (%set! (rename 'set!))
      (%error (rename 'error))
      (%apply (rename 'apply))
      (%begin (rename 'begin))
      (%lambda (rename 'lambda))
      (%bind-set! (rename 'bind-set!))
      )
      (letrec (
        ;; is argument a lambda-list?
        (lambda-list?
          (lambda (obj)
            (or (symbol? obj)
                (null? obj)
                (and (pair? obj)
                     (symbol? (car obj))
                     (lambda-list? (cdr obj))))))
        ;; map one flat pseudolist
        (pmap1
          (lambda (fn1 xpr)
            (cond
              ((null? xpr) '())
              ((pair? xpr)
               (cons (fn1 (car xpr)) (pmap1 fn1 (cdr xpr))))
              (else (fn1 xpr)))))
        ;; map two flat pseudolists
        (pmap2
          (lambda (fn2 xs ys)
            (cond
              ((and (null? xs) (null? ys)) '())
              ((and (pair? xs) (pair? ys))
               (cons (fn2 (car xs) (car ys)) (pmap2 fn2 (cdr xs) (cdr ys))))
              ((and (not (pair? xs)) (not (pair? ys)))
               (list (fn2 xs ys)))
              (else
                (error 'pmap2 "unequal length" xs ys)))))
;The dissect helper transforms a nested lambda-list, deep, into a list,
;(flat acc ...), where flat replaces each pair in deep by a gensym and
;acc ... collects flat and the (pair gensym) pairs, e.g.  (x (y . z) (a
;b)) -> ((x g1 g2) ((a b) g2) ((y . z) g1)) where g1, g2 are gensyms.
        ;;transform a nested lambda-lists into a sequence of flat ones
        (dissect
          (lambda (deep)
            (let ((acc '()))
              (let (
                (flat (pmap1 (lambda (x)
                              (if (pair? x)
                                (let ((g (gensym)))
                                  (set! acc (cons (list x g) acc))
                                  g)
                                x))
                            deep))
                )
                (cons flat acc)))))
        )
        (if (lambda-list? pat)
;Let's start with the flat case, i.e. the case where the pattern
;is a lambda-list. We want the macro-code to be bound to a procedure
;invocation, as in ordinary let.
;To be more precise, we want the transformations
;(bind-set! a xpr) -> (set! a xpr) for symbols and
;(bind-set! (a b . c) xpr) -> (apply (lambda (%a %b . %c) . body) xpr)
;where prefixed symbols are renamed symbols and body set!s corresponding
;names to values.
          (cond
            ((null? pat)
             `(,%if (,%null? ,xpr)
                (,%void)
                (,%error 'bind-set! "can't set! to null? pattern")))
            ((symbol? pat)
             `(,%set! ,pat ,xpr))
            (else
              (let ((newpat (pmap1 rename pat)))
                `(,%apply (,%lambda ,newpat
                            ,@(pmap2 (lambda (p n) `(,%set! ,p ,n)) pat newpat))
                          ,xpr))))
;Now, having solved the flat case, how do we attack the nested case?
;How could we process a pattern of the form (a (b . c) (d e)), say? The
;idea is, to replace this nested list by one of a form which could be
;handled by the flat case. Well, we could replace the sublists by
;gensyms, resulting in a lambda-list, and pair each of the gensyms with
;the sublist it replaced. So the above helper procedure, dissect,
;transforms the above list into ((a g1 g2) ((d e) g2) ((b . c) g1)) with
;gensyms g1, g2.  Having done this, we can define the desired macro by
;recursion. 
          (let ((decls (dissect pat)))
            (let ((first (car decls)) (rest (cdr decls)))
               (let loop ((pats rest) (acc '()))
                 (if (null? pats)
                   `(,%begin 
                      (,%bind-set! ,first ,xpr)
                      ,@acc)
                   (loop (cdr pats)
                         (cons `(,%bind-set! ,@(car pats)) acc)))))))))))


;Now to the most important of these macros, bind. It is
;inspired by Common Lisp's macro destructuring-bind, which does, what
;its rather long name suggests, namely
;
;  (destructuring-bind (a (b (c . d) . e)) '(1 (2 (3 4 5) 6 7)) . body)
;
;will destructure its second argument, a list expression, according to
;its first argument, a nested lambda-list which serves as a pattern, and
;will bind the pattern variables a, b, c, d and e to the matching values
;in the list expression on the right, executing body in this new
;context.  The destructuring of dotted pairs means, that d and e are
;bound to the lists '(4 5) and '(6 7) respectively.
;
;Imagine, how complicated - and unreadable, by the way - the equivalent
;nested let expressions would be. So it's reasonable to let a macro
;generate this complicated let expression, and that's exactly, what
;destructuring-bind does.
;Moreover, destructuring-bind does the work of destructuring macro
;arguments in Common Lisp behind the scene, and since explicit renaming
;macros are similar to Common Lisp's defmacro, it pays to have an
;implementation of it in Chicken as well.
;Since I personally don't like such a long name, we'll simply use bind.
;
;Some uses and their results are as follows:
;  (bind (x (y (z . u)) . v) '(1 (2 (3 4 5))) (list x y z u v))
;  -> '(1 2 3 (4 5) ())
;  (bind x 1 x) -> 1
;  (bind (x y) '(1 2 3) (list x y)
;  -> match error

;A first attempt to implement this macro would be to follow the
;inductive definition of a pattern and take advantage of the fact,
;that macro definitions could be recursive. So we try
;
;(define-syntax bind
;  (syntax-rules ()
;    ((_ (a . b) xpr . body)
;     (bind a (car xpr)
;       (bind b (cdr xpr) . body)))
;    ((_ () xpr . body)
;     (if (null? xpr)
;       (begin . body)
;       (error 'bind "match error" '() xpr)))
;    ((_ a xpr . body)
;     (let ((a xpr)) . body))))
;
;This is really easy, but too easy, as it appears. In fact, this macro
;would traverse its pattern argument depth-first, and hence a
;lambda-list sequentially, and that is not what we want. We want them
;bound in parallel and want the symbols of a deeper nesting level be
;able to refer to those of a higher level.

;Having bind-define under our belt, the implementation of this and
;almost all of the following macros is an easy application of
;syntax-rules.

;;; (bind pat xpr0 xpr . xprs)
;;; --------------------------
(define-syntax-with-contract bind
  "binds pattern variables of pat to subexpressions of xpr0 and executes xpr ..."
  (syntax-rules ()
    ((_ pat xpr0 xpr . xprs)
     (begin
       (bind-define pat xpr0) xpr . xprs))))

;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 pat xpr . xprs)
;;; ----------------------------
(define-syntax-with-contract bind-lambda
  "combination of lambda and bind, one pattern argument"
  (syntax-rules ()
    ((_ pat xpr . xprs)
     (lambda (x) (bind pat x xpr . xprs)))))

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

;The next macro checks, if a nested pseudolist expression matches a
;pattern. There are two variants, one with an additional test
;procedure, a thunk, the other without. Calling the thunk we can reject
;an expression which would otherwise match the pattern argument.
;Typical uses with their results are

;(let ((xpr '(1 2)))
;  (bind-matches? (a b) xpr (lambda () (even? (apply + xpr))))) -> #f
;(bind-matches? (a (b . c) d) '(1 (2 3) 4)) -> #t
;(bind-matches? (a (b c) d) '(1 (2 3) 4 5)) -> #f

;The implementation simply traverses the pattern argument depth-first
;(the choice we had rejected for bind-set!).

;;; (bind-matches? pat xpr [ok?])
;;; ------------------------------
;;; predicate to return #t only if xpr matches pat
;;; [and (ok?) is true for thunk ok?]
(define-syntax-with-contract bind-matches?
  "matches pattern expression [and is (ok?) true]?"
  (syntax-rules ()
    ((_ () xpr)
     (null? xpr))
    ((_ (a . b) xpr)
     (and (pair? xpr)
          (bind-matches? a (car xpr))
          (bind-matches? b (cdr xpr))))
    ((_ a xpr)
     #t)
    ((_ pat xpr ok?)
     (and (bind-matches? pat xpr) (ok?)))))

;Now comes a macro, which does more or less the same as the
;match macro in the matchable package: It matches an expression,
;xpr0, against a series of patterns, each paired with a body to execute
;if that pattern is matched. The body of the first matching pattern is
;executed. And again, there is a variant with =>, where a test?
;thunk can be used as a fender to reject an otherwise matching
;expression.  
;A typical use is the definition of the map procedure for lists
;
;(define my-map
;  (lambda (fn lst)
;    (bind-case lst
;      (() '())
;      ((x . xs) (cons (fn x) (map fn xs))))))
;
;The implementation simply combines bind-maches? and bind.

;;; (bind-case xpr0 clause clause1 ...)
;;; ----------------------------------
;;; where each clause is either of the form (pat xpr . xprs)
;;; or (pat (=> ok?) xpr . xprs) with ok? a thunk, which can be used to
;;; reject an otherwise matching pattern.
(define-syntax-with-contract bind-case
  "matches xpr0 against a series of patterns [with fender test?, a thunk]
 and executes the body of the first matching pattern satisfying (test?)"
  (syntax-rules (=>)
    ;; one (pat xpr . xprs) pair, with or without fender
    ((_ xpr0 (pat (=> test?) xpr . xprs))
     (if (bind-matches? pat xpr0 test?)
       (bind pat xpr0 xpr . xprs)
       (error 'bind-case "no pattern matches" xpr0)))
    ((_ xpr0 (pat xpr . xprs))
     (if (bind-matches? pat xpr0)
       (bind pat xpr0 xpr . xprs)
       (error 'bind-case "no pattern matches" xpr0)))
    ;; multiple (pat xpr . xprs) pairs, with or without fender
    ;((_ xpr clause clause1 ...) ; wrong
    ; (bind-case xpr clause clause1 ...))))
    ((_ xpr0 (pat (=> test?) xpr . xprs) clause ...)
     (if (bind-matches? pat xpr0 test?)
       (bind pat xpr0 xpr . xprs)
       (bind-case xpr0 clause ...)))
    ((_ xpr0 (pat xpr . xprs) clause ...)
     (if (bind-matches? pat xpr0)
       (bind pat xpr0 xpr . xprs)
       (bind-case xpr0 clause ...)))))

;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) (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 clause clause1 ...)
;;; -------------------------------------
;;; where each clause is either of the form (pat xpr . xprs)
;;; or (pat (=> ok?) xpr . xprs) with ok? a thunk, which can be used to
;;; reject an otherwise matching pattern.
(define-syntax-with-contract bind-case-lambda
  "combination of bind-case and lambda with one pattern argument"
  (syntax-rules (=>)
    ((_ (pat xpr . xprs))
     (lambda (x) (bind pat x xpr . xprs)))
    ((_ (pat (=> ok?) xpr . xprs))
     (lambda (x) (bind-case pat (=> ok?) x xpr . xprs)))
    ((_ clause clause1 ...)
     (lambda (x)
       (bind-case x clause clause1 ...)))))
;;; (bind-case-lambda* clause clause1 ...)
;;; --------------------------------------
;;; where each clause is either of the form (pat xpr . xprs)
;;; or (pat (=> ok?) xpr . xprs) with ok? a thunk, which can be used to
;;; reject an otherwise matching pattern.
(define-syntax-with-contract bind-case-lambda*
  "combination of bind-case and lambda with multiple pattern arguments"
  (syntax-rules (=>)
    ((_ (pat xpr . xprs))
     (lambda x (bind pat x xpr . xprs)))
    ((_ (pat (=> ok?) xpr . xprs))
     (lambda x (bind-case pat (=> ok?) x xpr . xprs)))
    ((_ clause clause1 ...)
     (lambda x
       (bind-case x clause clause1 ...)))))

;The macro bind-loop is to bind what named let is to let. 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 subexpressins
;in xpr. For example
;(bind-loop proc (x y) '(5 0)
;  (if (zero? x)
;    (list x y)
;    (proc (sub1 x) (add1 y))))
;-> '(0 5)
;The implementation is a combination of letrec and bind.

;;; (bind-loop proc pat xpr0 xpr . xprs)
;;; ------------------------------------
;;; named version of bind
(define-syntax-with-contract bind-loop
  "bind-loop is for bind what named let is for let"
  (syntax-rules ()
    ((_ proc pat xpr0 xpr . xprs)
     (apply (letrec ((proc (lambda x (bind pat x xpr . xprs)))) proc)
            xpr0))))

;Now the implementation of a nested version of let, named and unnamed,
;is easy: Simply combine bind and bind-loop. 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] ((pat0 xpr0) ...) xpr . xprs)
;;; ----------------------------------------------
;;; nested version of let, named and unnamed
(define-syntax-with-contract bind-let
  "like let, but binds patterns to templates"
  (syntax-rules ()
    ((_ () xpr . xprs)
     (begin xpr . xprs))
    ((_ ((pat0 xpr0) (pat1 xpr1) ...) xpr . xprs)
     (bind (pat0 pat1 ...) (list xpr0 xpr1 ...) xpr . xprs))
    ((_ loop () xpr . xprs)
     (let loop () xpr . xprs))
    ((_ loop ((pat0 xpr0) ...) xpr . xprs)
     (bind-loop loop (pat0 ...) (list xpr0 ...) 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* ((pat0 xpr0) ...) xpr . xprs)
;;; ----------------------------------------
;;; sequential version of bind-let
(define-syntax-with-contract bind-let*
  "like let*, but binds patterns to templates"
  (syntax-rules ()
    ((_ () xpr . xprs)
     (let () xpr . xprs))
    ((_ ((pat0 xpr0) decl ...) xpr . xprs)
     (bind pat0 xpr0 (bind-let* (decl ...) xpr . xprs)))))

;Now, we'll supply a recursive version of bind. The following is a
;rather contrieved example
;(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)
;
;A simplified implementation could look like this
;
;(define-syntax bindrec
;  (syntax-rules ()
;    ((_ pat xpr . body)
;     ;; bind pattern variables temporarily to its names ...
;     (bind pat 'pat
;       ;; ... and  set! them
;       (bind-set! pat xpr) . body))))
;
;but in fact we use some additional indirection like in the definition
;of letrec. This indirection is supplied in the let line, where we
;define an auxiliary pattern with gensymed names by means of the helper
;macro map-pat defined below. We will do the same in the bind-set!
;macro for lambda-lists, but there we used the local function pmap1.

;;; (bindrec pat0 xpr0 xpr . xprs)
;;; ------------------------------
;;; recursive version of bind.
(define-syntax-with-contract bindrec
  "bind patterns recursively"
  (syntax-rules ()
    ((_ pat0 xpr0 xpr . xprs)
     (let ((aux0 (map-pat gensym pat0)))
       (bind pat0 'pat0
         (bind aux0 xpr0
           (bind-set! pat0 aux0) xpr . xprs))))))

;;; (map-pat proc pat)
;;; ------------------
;;; This is a helper macro, which is implemented as a macro instead of a
;;; function, so that it is visible at compile time. It uses the canonical
;;; depth-first traversal of patterns.
(define-syntax map-pat
  (syntax-rules ()
    ((_ fn (a . b))
     (cons (map-pat fn a) (map-pat fn b)))
    ((_ fn ()) '())
    ((_ fn a) (fn 'a))))

;;;(bind-letrec ((pat0 xpr0) ...) xpr . xprs)
;;;------------------------------------------
;;;This nested version of letrec is simply an application of bindrec.
(define-syntax-with-contract bind-letrec
  "like letrec, but binds patterns to templates"
  (syntax-rules ()
    ((_ ((pat0 xpr0) ...) xpr . xprs)
     (bindrec (pat0 ...) (list xpr0 ...) xpr . xprs))))

;;; (bind-mapped syms proc xpr . xprs) ; c/o bind-flat
;;; ----------------------------------
;;; binds a list of symbols, syms, to its image under proc and evaluates
;;; xpr ... in this new context
;(define-syntax bind-mapped
;  (syntax-rules ()
;    ((_ () proc xpr . xprs) (begin xpr . xprs))
;    ((_ (sym sym1 ...) proc xpr . xprs)
;     ;(let ((sym (proc 'sym)) (sym1 (proc 'sym1)) ...) xpr . xprs))
;     (apply (lambda (sym sym1 ...) xpr . xprs)
;            (map proc '(sym sym1 ...))))
;    ((_ sym proc xpr . xprs)
;     ((lambda (sym) xpr . xprs) (proc 'sym)))))

;;; (bind-flat pat xpr . body)|(bind-flat pat => proc . body)
;;; ---------------------------------------------------------
;;; where pat is a lambda-list in the first case, and a symbol or list in
;;; the second. Binds the symbols of pat to the corresponding
;;; subexpressions of xpr0 or (proc 'pat)|(map proc 'pat) and executes body
;;; in this new context.
(define-syntax-with-contract bind-flat
  "bind flat patterns to expression or (with =>) its value under proc"
  (syntax-rules (=>)
    ((_ () => proc xpr . xprs) (begin xpr . xprs))
    ((_ () tpl xpr . xprs) (begin xpr . xprs))
    ((_ (sym sym1 ...) => proc xpr . xprs)
     (bind-flat (sym sym1 ...) (map proc '(sym sym1 ...)) xpr . xprs))
    ((_ (sym sym1 ...) tpl xpr . xprs)
     (apply (lambda (sym sym1 ...) xpr . xprs) tpl))
    ((_ (x . y) tpl xpr . xprs)
     (apply (lambda (x . y) xpr . xprs) tpl))
    ((_ sym => proc xpr . xprs)
     ((lambda (sym) xpr . xprs) (proc 'sym)))
    ((_ sym tpl xpr . xprs)
     ((lambda (sym) xpr . xprs) tpl))))
                  
;;; (bind-flat-let* ((pat0 xpr0)|(pat => proc) ...) . body)
;;; --------------------  ---------------------------------
;;; binds sequentially the symbols of the lambda-list pat to the
;;; corresponding subexpressions of xpr|(proc pat) and executes body in
;;; this new context.
(define-syntax-with-contract bind-flat-let*
  "let* for flat patterns or (with =>) procedures"
  (syntax-rules (=>)
    ((_ () xpr . xprs)
     (let () xpr . xprs))
    ((_ ((pat0 => xpr0) decl ...) xpr . xprs)
     (bind-flat pat0 => xpr0 (bind-flat-let* (decl ...) xpr . xprs)))
    ((_ ((pat0 xpr0) decl ...) xpr . xprs)
     (bind-flat pat0 xpr0 (bind-flat-let* (decl ...) xpr . xprs)))))

(define bindings (doclist->dispatcher (doclist))) ;!!!!!!!!!!!!!!!!

) ; module bindings