; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2011-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.
;
;Binding pattern variables to subsequences
;=========================================
;
;In this module, you'll find macros, which all operate on patterns, that
;is, nested lambda-lists. 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 or
;anested-lambda-list, whose formal definition is
;
;nested-lambda-list? :=
;  symbol? | null? | (cons nested-lambda-list?
;                          nested-lambda-list?)
;
;We'll define a list of operators, most of them binding constructs and
;hence macros, which bind pattern variables, i.e. the symbols of a
;pattern, to corresponding subexpressions of an expression and execute
;some body in this scope. The most fundamental of this operators is
;bind, which is roughly the same as destructuring-bind in Common Lisp.
;For example
;
;  (bind (u (v (w . x) y) . z) '(1 (2 (3) 4) 5 6) (list u v w x y z))
;
;will return (1 2 3 () 4 (5 6)).
;
;In this example the expression to be destructured is a nested list,
;'(1 (2 (3) 4) 5 6), and this is the most important case. But as Paul
;Graham in his classic "On Lisp" notes, there is no need to restrict
;oneself to nested lists, arbitrary nested sequences should do as well.
;Unfortunately, standard Scheme doesn't have a sequence datatype but
;Chicken has a corresponding egg. This could be used, but this would be
;sort of overkill.
;
;Internally, we'll use three generic functions instead, generic-car,
;generic-cdr and generic-null? which are able to handle not only lists,
;but vectors and strings as well. So our binding macros work on
;arbitrary mixtures of (pseudo-) lists, strings and vectors as given.
;But since they operate by searching a local table, we can add other
;type-operator-pairs to these tables, thus enhancing the binding
;operators to other sequence types, say tuples, lazy-lists or what have
;you, without touching the macros itself! To be more precise, we need to
;export only one function, generic-null-car-cdr!, which maintains the
;table for the other three generics, and which can be used by clients to
;add other relevant operator triples.
;
;I've added one additional twist. The bodies of bind and some other
;macros can start with an optional where-clause, (where . fenders),
;which means, that a match is only considered successfull, if all
;fenders evaluate to true.
;
;Below, I'll freely use not only ellipses, i.e. three dots, meaning
;"repeat the pattern to the left zero or more times", but also two dots
;and four dots to repeat the pattern(s) to the left "zero or one
;times" or "one or many times" respectively.
;

(require-library lolevel)

(module bindings
    (bindings (bind generic-car generic-cdr generic-null?)
              bindable? bind-case
              bind-let bind-let* bind-letrec
              bindrec bind-lambda bind-lambda* bind* bind-set!
              bind-define bind-case-lambda bind-case-lambda*
              ;; the generics updater must be exported for bind to be extensible
              generic-null-car-cdr!)

(import scheme
        (only data-structures list-of?)
        (only extras format)
        (only lolevel record-instance? record->vector)
              ;extend-procedure procedure-data)
        (only chicken condition-case case-lambda
              print error gensym fx- fx+ fx=))

(import-for-syntax (only data-structures flatten))

;We begin with the implementation of bind, following Graham, p.232.
;Since Graham's code doesn't check, if the sequence's length
;matches the length of a list pattern, we add such a check, by simply
;collecting the sequence's tail with index the pattern's length in a
;separate list, checks.

;;; (bind pat seq (where . fenders) .. xpr . xprs)
;;; ----------------------------------------------
;;; binds pattern variables of pat to correspondign subexpressions
;;; of seq and executes 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
  (ir-macro-transformer
    (lambda (form inject compare?)
      ;; check syntax
      (if
        (and
          (> (length form) 3)
          ;; nested lambda-list?
          ((lambda (x)
             (let loop ((x x))
               (cond
                 ((null? x) #t)
                 ((symbol? x) #t)
                 ((pair? x)
                  (and (loop (car x))
                       (loop (cdr x))))
                 (else #f))))
           (cadr form))
        )
        ;; destructure and helpers
        (let (
          (pat (cadr form))
          (seq (caddr form))
          (body (cdddr form))
          (fender?
            (lambda (x)
              (and (list? x) (not (null? x)) (compare? (car x) 'where))))
          )
          (letrec (
            (checks '()) ; to be populated by destruc
            (destruc
              (lambda (pat seq)
                (cond
                  ((null? pat)
                    (set! checks (cons `(generic-null? ,seq) checks))
                    '())
                  ((symbol? pat) `((,pat ,seq)))
                  ((pair? pat) (append (destruc (car pat) `(generic-car ,seq))
                                       (destruc (cdr pat) `(generic-cdr ,seq))))
                  )))
            )
            (let (
              (body (if (fender? (car body)) (cdr body) body))
              (fender (if (fender? (car body)) (cons 'and (cdar body)) #t))
              )
              (let* ((decls (destruc pat seq))
                     (vars (map car decls)))
                `(let ,decls
                   (if (and (not (memq #f ,(cons 'list checks)))
                            ((lambda ,vars ,fender) ,@vars))
                       ((lambda ,vars ,@body) ,@vars)
                      (error 'bind
                              (format #f
                               "expression ~a doesn't match pattern ~a where ~a~%"
                               ,seq ',pat ',fender))))))))
        (syntax-error 'bind
          "\nuse (bind pat seq (where . fenders) .. xpr . xprs)
with nested lambda-list pat")))))

;The macro bind* 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 seq. For example
;
;(bind* loop (x y) '(5 0)
;  (if (zero? x)
;    (list x y)
;    (loop (list (sub1 x) (add1 y)))))
;-> '(0 5)

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

;The following macro returns a precedure, which checks, if its sequence
;argument matches against any of the macro's pattern arguments, and is
;hence bindable to one of the patterns. The optional where clauses are
;considered part of the matching process. Example:
;
;((bindable? (a b) (where (even? a)) (a b)) '#(1 2)) -> #t 
;
;;; (bindable? pat (where . fenders) .. ....)
;;; -------------------------------------
(define-syntax bindable?
  (syntax-rules (where)
    ((_)
     (lambda (form) (null? form)))
    ((_ pat (where . fenders))
     (lambda (form)
       (condition-case
         (bind pat form (and . fenders))
         ((exn) #f))))
    ((_ pat)
     (lambda (form)
       (condition-case
         (bind pat form #t)
         ((exn) #f))))
    ((_ pat (where . fenders) . clauses)
     (lambda (form)
       (or ((bindable? pat (where . fenders)) form)
           ((bindable? . clauses) form))))
    ((_ pat . clauses)
     (lambda (form)
       (or ((bindable? pat) form)
           ((bindable? . clauses) form))))))

;The following macro does more or less the same as the match macro from
;the matchable package:
;
;(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))
;
;;; (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))
     (bind pat seq (where . fenders) xpr . xprs))
    ((_ seq (pat xpr . xprs))
     (bind pat seq xpr . xprs))
    ((_ seq clause . clauses)
     (condition-case
       (bind-case seq clause)
       ((exn)
        (bind-case seq . clauses))))))

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

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

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

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

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

;;; (bind-case-lambda (pat (where . fenders) .. xpr . xprs) ....)
;;; -------------------------------------------------------------
(define-syntax bind-case-lambda
  (syntax-rules (where)
    ((_ (pat (where . fenders) xpr . xprs))
     (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
    ((_ (pat xpr . xprs))
     (lambda (x) (bind pat x xpr . xprs)))
    ((_ clause . clauses)
     (lambda (x)
       (bind-case x clause . clauses)))))

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

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

;Now the implementation of a nested version of let, named and unnamed,
;is easy: Simply combine bind and bind*. For example
;
;(bind-let (
;   (((x y) z) '((1 2) 3))
;   (u (+ 2 2))
;   ((v w) '(5 6))
;   )
;   (list x y z u v w))
;-> '(1 2 3 4 5 6)
;
;(bind-let loop (((a b) '(5 0)))
;  (if (zero? a)
;    (list a b)
;    (loop (list (sub1 a) (add1 b)))))
;-> '(0 5)

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

;The sequential version of bind-let should work as follows
;
;(bind-let* (
;   (((x y) z) '((1 2) 3))
;   (u (+ 1 2 x))
;   ((v w) (list (+ z 2) 6))
;   )
;   (list x y z u v w))
;-> '(1 2 3 4 5 6)

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

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

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

;And here is the recursive version of bind, on which bind-letrec is
;based.

;(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 seq . body)
;     ;; bind pattern variables temporarily to its names ...
;     (bind pat 'pat
;       ;; ... and  set! them
;       (bind-set! pat seq) . 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 aux, which is a gensymed version of pat
;
;;; (bindrec pat seq xpr . xprs)
;;; ----------------------------
;;; recursive version of bind
(define-syntax bindrec
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form)) (seq (caddr form)) (body (cdddr form)))
        (letrec (
          (gensymed
            (lambda (pat)
              (let loop ((pat pat))
                (cond
                  ((null? pat) '())
                  ((symbol? pat) (gensym pat))
                  (else
                    (cons (loop (car pat))
                          (loop (cdr pat))))))))
          )
          `(let ((aux ',(gensymed pat)))
             (bind ,pat ',pat
                (bind aux ,seq
                  (bind-set! ,pat aux)
                  ,@body))))))))

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

;bind-set! replaces the values of symbols in a nested lambda-list in one
;go with the corresponding subeseqessions of its second argument. So,
;after (bind-set! (a (b (c . d))) '(1 (2 (3 4 5)))) d should have the
;value (4 5), b the value 2 etc. 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 (seq) (set! lst (cons seq 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 (seq) (set! stack (cons seq stack)))
;        (lambda () (set! stack (cdr stack))))))
;
;but now, stack is not read-only: It could be changed from outside by set!
;
;The implementation uses the bind macro. The idea is simply to map the
;pattern to a new pattern with gensyms as pattern variables, then bind
;these new pattern variables to subexpressions of seq via bind and then
;export a series of (set! var new-var) expressions in bind's body. For
;this to work we need a local helper-function, flatten. The use of local
;helpers 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.
;
;By the way, the choice of local functions which are called outside
;backquotes or inside unquotes 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 seq)
;;; -------------------
;;; destructures seq according to pat and defines pattern variables
;;; with values corresponding to subexpressions of seq
(define-syntax bind-set!
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form)) (seq (caddr form)))
        (letrec (
          (flatten (lambda (pat)
                     (cond
                       ((null? pat) '())
                       ((symbol? pat) (list pat))
                       (else
                         (append (flatten (car pat))
                                 (flatten (cdr pat)))))))
          )
          (let (
            ;; pat mapped by gensym
            (aux
              (let loop ((pat pat))
                (cond
                  ((null? pat) '())
                  ((symbol? pat) (gensym pat))
                  (else
                    (cons (loop (car pat))
                          (loop (cdr pat)))))))
            )
            `((bind-lambda ,aux
                ,@(map (lambda (p g) `(set! ,p ,g))
                       (flatten pat) (flatten aux)))
              ,seq)))))))

;Here is an example of bind-define
;
;(bind-define (top push! pop!)
;  (let ((lst '()))
;    (vector
;      (lambda () (car lst))
;      (lambda (xpr) (set! lst (cons xpr lst)))
;      (lambda () (set! lst (cdr lst))))))

;;; (bind-define pat seq)
;;; ---------------------
;;; destructures seq according to pat and sets pattern variables
;;; with values corresponding to subexpressions of seq
(define-syntax bind-define
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let (
        (pat (cadr form))
        (seq (caddr form))
        (flat-pat
          (let loop ((pat (cadr form)))
            (cond
              ((null? pat) '())
              ((symbol? pat) (list pat))
              (else
                (append (loop (car pat))
                        (loop (cdr pat)))))))
        )
        `(begin
           (syms->vars ,@flat-pat)
           (bind-set! ,pat ,seq))))))

;;; (syms->vars sym0 sym1 ...)
;;; --------------------------
;;; transforms its argument symbols to variables with their own names as
;;; values
(define-syntax syms->vars
  (syntax-rules ()
    ((_ sym0 sym1 ...)
     (begin
       (define sym0 'sym0)
       (define sym1 'sym1)
       ...))))

;Now to the generic functions
;
;; helper for generics, since subvector is still buggy
(define (vector-tail vec from)
  (let ((len (##sys#size vec))) ;(vector-length vec)))
    (##sys#check-range from 0 (+ len 1) 'vector-tail)
    (let* (
      (new-len (fx- len from))
      (result (make-vector new-len #f))
      )
      (do
        ((k 0 (fx+ k 1)))
        ((fx= k new-len) result)
        (##sys#setslot result k (##sys#slot vec (fx+ k from)))))))

(define generic-null-car-cdr!
  (let (
    (table
      (list
        (cons ;(extend-procedure list? 'list?)
              list?
              (vector null? car cdr))
        (cons ;(extend-procedure pair? 'pair?)
              pair?
              (vector (lambda () #f) car cdr))
        (cons ;(extend-procedure vector? 'vector?)
              vector?
              (vector
                (lambda (seq) (zero? (vector-length seq)))
                (lambda (seq) (vector-ref seq 0))
                (lambda (seq) (vector-tail seq 1))))
        (cons ;(extend-procedure string? 'string?)
              string?
              (vector
                (lambda (seq) (zero? (string-length seq)))
                (lambda (seq) (string-ref seq 0))
                (lambda (seq) (substring seq 1))))
        (cons ;(extend-procedure record-instance? 'record-instance?)
              record-instance?
              (vector
                (lambda (seq) (= 1 (vector-length (record->vector seq))))
                (lambda (seq) (vector-ref (record->vector seq) 1))
                (lambda (seq)
                  (vector-tail (record->vector seq) 2))))))
                  ;(let ((lst (vector->list (record->vector seq))))
                  ;  (cons (car lst) (cddr lst))))))))
    )
    (lambda args
      (cond
        ;; add to table
        ((and ((list-of? procedure?) args)
              (= (length args) 4))
         (set! table
               (cons (cons (car args)
                           (apply vector (cdr args)))
                     table)))
        ;; search table
        ((= (length args) 1)
         (let loop ((tbl table))
           (cond
             ((null? tbl)
              (error 'generic-null-car-cdr!
                     (format #f
                             "not in type list ~s: ~s"
                             ;(map procedure-data (map car table))
                             (map car table)
                             (car args))))
             (((caar tbl) (car args))
              (cdar tbl))
             (else
               (loop (cdr tbl))))))
        (else
          (error 'generic-null-car-cdr!
                 "wrong arguments"))))))

(define (generic-null? seq)
  ((vector-ref (generic-null-car-cdr! seq) 0) seq))
(define (generic-car seq)
  ((vector-ref (generic-null-car-cdr! seq) 1) seq))
(define (generic-cdr seq)
  ((vector-ref (generic-null-car-cdr! seq) 2) seq))

(define bindings
  (let (
    (alist '(
      (bind
        "a variant of Common Lisp's destructuring-bind macro"
        (bind pat seq (where . fenders) .. xpr . xprs)
"Destructures the sequence expression seq according to the pattern pat,
checking the optional fenders, binds pattern variables of pat to
corresponding subexpressions of seq and executes xpr . xprs in this
context")
      (bind-set!
        "sets multiple variables by destructuring its sequence argument"
        (bind-set! pat seq)
    "destructures seq according to pat and sets pattern variables
with values corresponding to subexpressions of seq")
      (bind-define
        "defines multiple variables by destructuring its sequence argument"
        (bind-define pat seq)
    "destructures seq according to pat and defines pattern variables
with values corresponding to subexpressions of seq")
      (bindable?
        "returns a predicate, which checks if its argument matches
one of the pattern arguments of bindable?"
        (bindable? pat (where . fenders) .. ....))
      (bind-case
        "a variant of matchable's match macro."
        (bind-case seq (pat (where . fenders) .. xpr . xprs) ....)
"Checks if seq matches patterns pat checking fenders in sequence,
binds the pattern variables of the first matching pattern to
corresponding subexpressions of seq and executes corresponding body
in this context")
      (bind-lambda
        "combination of lambda and bind, one pattern argument"
        (bind-lambda pat (where . fenders) .. xpr . xprs))
      (bind-lambda*
        "combination of lambda and bind, multiple pattern arguments"
        (bind-lambda* pat (where . fenders) .. xpr . xprs))
      (bind-case-lambda
        "combination of lambda and bind-case with one pattern argument"
        (bind-case-lambda clause ....)
"where each clause is either of the form (pat xpr . xprs)
or (pat (where . fenders) xpr . xprs) where fenders can be used to
reject an otherwise matching pattern")
      (bind-case-lambda*
        "combination of lambda and bind-case with multiple pattern arguments"
        (bind-case-lambda* clause ....)
"where each clause is either of the form (pat xpr . xprs)
or (pat (where . fenders) xpr . xprs) where fenders can be used to
reject an otherwise matching pattern")
      (bind*
        "named version of bind"
        (bind* loop pat seq xpr . xprs)
"where loop evaluates to a one-parameter procedure to be used in xpr . xprs")
      (bind-let
        "nested version of let, named and unnamed"
        (bind-let loop .. ((pat seq) ...) xpr . xprs)
"binds pattern variables of pat ... to matching positions of seq ...
in parallel and executes xpr . xprs in this context. If loop is provided,
it evaluates to a one-parameter procedure available in the body xpr . xprs")
      (bind-let*
        "sequential version of let"
        (bind-let ((pat seq) ...) xpr . xprs)
"binds pattern variables of pat ... to matching positions of seq ...
sequentially and executes xpr . xprs in this context")
      (bind-letrec
        "recursive version of bind-let"
        (bind-letrec ((pat seq) ...) xpr . xprs)
"binds pattern variables of pat ... to matching positions of seq ...
recursively and executes xpr . xprs in this context")
      (bindrec
        "recursive version of bind"
        (bindrec pat seq . body)
"like bind, but seq can contain references to pattern variables in pat")
      (generic-null-car-cdr!
        "command updating the table of the following generic functions"
        (generic-null-car-cdr! type-predicate null-proc car-proc cdr-proc))))
      )
      (case-lambda
        (() (map car alist))
        ((sym)
         (let ((pair (assq sym alist)))
           (if pair
             (cdr pair)
             (print "Choose one of " (map car alist))))))))

) ; module bindings