;;;; File: contracts.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Oct 24, 2010
;;;;       Nov 28, 2010
;;;;       Dec 06, 2010
;;;;       Jan 04, 2011
;;;;       Jan 07, 2011
;;;;       Jan 12, 2011
;;;;       Jan 20, 2011
;;;;       Jan 31, 2011
;;;;       Feb 16, 2011
;;;;       Feb 22, 2011
;;;;       Jun 19, 2011
;;;;       Jul 09, 2011
;;;;       Jul 19, 2011
;;;;       Jul 22, 2011
;;;;       Jul 26, 2011
;;;;       Jul 31, 2011
;;;;       Aug 15, 2011

;Design by Contract
;==================
;
;Design by Contract is a programming paradigm invented by Bertrand Meyer
;for his purely Object Oriented Language Eiffel. The objective is to
;reduce the complexity of software by means of a clear separation of
;concerns between its suppliers and clients. One of the rules is: Never
;do a check an both sides of the abstraction barrier. To achieve this,
;Eiffel fosters a style, in which each routine clearly specifies, what
;are the assumptions (preconditions) of a routine and what are its
;propositions (postconditions). Moreover, the runtime system is able to
;check these conditions. If now a routine call fails because of illegal
;arguments, the client is to blame, but if it fails with violated
;propositions, it is the supplier's fault. The routine's body will not
;even be accessed with wrong arguments, and the routine will not even
;return with wrong propositions.
;
;The metaphor is that of a contract between supplier and client. The
;supplier guarantees correct results, provided the client fulfills his
;duties. If not, the supplier is not obligated to start work at all. As
;in real life, both parties need a copy of the contract, and there must
;be a judge in case of troubles. Translated to programming, this means,
;the contract needs to be documented, and both parties can trust each
;other, so that they need not - and should not - check the other's
;duties, the runtime system will do it. It's a bit like proving a
;mathematical theorem: to prove its proposition, the assumptions can be 
;taken for granted. Without them, the proposition is simply meaningless.
;
;There is still another metaphor of Meyer's, Command-Query-Separation.
;That means, that the programmer should never write routines both for a
;result and for a side-effect (like the ++ operators in C). Instead, two
;routines should be written, one that returns a result, the other that
;changes state. The former are called queries by Meyer, the latter
;commands (because all of Eiffel's routines operate on objects, they
;either query or command its state). In Scheme we have functions without
;side-effect, written for their results only (the recommended style), and
;state-changing procedures, which are normally denoted with a trailing
;bang. But independent of the different terminology, the principle
;applies to Scheme as well, in fact to every language.
;
;Design by Contract is such a powerful paradigm, that anybody, who ever
;has programmed in Eiffel, would like to have it in his favorite
;language. Outside the Lisp family of languages, you where out of luck,
;but Lisps, being programmable programming languages, allow you to add
;to the language what you miss. In Lisp, you are a language designer as
;well as a programmer! In what follows, you'll see, how easy it is to
;implement Design by Contract in Chicken Scheme. 
;
;Let's start with the design. We'll package the needed macros and
;procedures in a Chicken module called contracts. The fundamental macros
;are called define-with-contract and define-syntax-with-contract, which
;replace and wrap define and define-syntax respectively. So
;instead of
;
;  (define name proc)
;
;you will write
;
;  (define-with-contract name 
;    contract-expression
;    proc)
;
;or - for closures with state -
;
;instead of 
;
;  (define name
;    (let (...)
;    proc))
;
;  (define-with-contract name
;    (let (...)
;      contract-expression
;      proc))
;
;where other binding constructs will work as well.
;
;And instead of
;
; (define-syntax name transformer)
;
;you'll write
;
;  (define-syntax-with-contract name
;    contract-expression
;    transformer)
;
;where proc is a lambda expression and transformer a syntax-rules
;expression in most cases. In both cases, there are short forms as well.
;
;But before we go into the details, how such a contract-expression looks
;like, it should be noted, that this macro should automate the
;documentation of the contract to be supplied.  After all, a contract
;without the contract document - the small print - is useless. To do
;this, we export a parameter, doclist, and a procedure,
;doclist->dispatcher, which are used by client code, preferably a
;module, as follows: At the start of the client module, doclist is
;initialized to the empty list, (doclist '()) and at the end it is saved
;to a dispatcher, say client, with
;
;  (define client (doclist->dispatcher (doclist))).
;
;Between these two calls every instance of define-with-contract and
;define-syntax-with-contract will store its textual representation of
;contract-expression under the symbol name, so that a client of the
;client-module, client, say, can either call (client) to get a list of
;available names, or (client 'name) to get documentation of the name
;routine.
;
;Let's start with the contract-expression above, in other words, how
;does a contract look like? The answer differs for procedures and macros
;as well as for queries and commands, or - to express this more
;Lisp-like - for functions (in the strict mathematical sense, i.e.
;without side-effects) and procedures with state, and it is different
;for macros as well.
;
;Let's start with functions.
;---------------------------
;
;Mathematical functions have a domain and a range, Lisp functions have
;arguments (possibly none at all) and results (possibly more than one).
;Consequently, a function contract should have a (domain: ...) and a
;(range: ...) clause. In the former, predicates on the arguments are
;listed, in the latter predicates on the results. But since result names
;are not declared in a function declaration, we must do it in the
;contract, preferably in the range: clause. We use 
;
;  (with-results (result0 result1 ...) xpr . xprs)
;
;there. But most functions have only one result. So we supply that
;very name "result" as default, which makes the (with-result ...) list 
;expendable. In sum, the typical range: clause looks like this
;
;  (range: xpr . xprs)
;
;where xpr xprs are predicates on result.

;And last, but not least, for documentation purposes, there should be a
;docstring. All this should appear after the call structure of the
;routine to be checked, which is the only required argument.
;So for Euclid's integer division, to give a typical example, the
;contract should look like this
;
;  (contract (quotient+remainder m n)
;    "integer division"
;    (domain:
;      (integer? m)
;      (not (negative? m))
;      (integer? n)
;      (positive? n)
;      (<= n m))
;    (range:
;      (with-results (q r)
;        (integer? q)
;        (integer? r)
;        (= (+ (* q n) r) m))))
;
;Put together, the whole checked quotient+remainder routine will look
;like this
;
;  (define-with-contract quotient+remainder
;    (contract (quotient+remainder m n) ...) ; see above
;    (lambda (m n)
;      (let loop ((q 0) (r m))
;        (if (< r n)
;          (values q r)
;          (loop (add1 q) (- r n))))))
;
;You should note, that contract and implementation are strictly
;separated. You as the supplier can write the implementation without
;worrying about the parameters in the implementation, it's checked by
;the contract. In fact, you mustn't, it's the client's duty. On the
;other hand, the client can be sure, that the routine delivers the
;correct results, provided it runs through.
;
;How is this black magic possible? It's simple: In Scheme, procedures are
;first class values. They can be arguments and results of procedures.
;Hence, we only need to implement the contract-expression as a macro,
;which returns a procedure, accepting the implementation as argument and
;returning the contract-checked implementation. 
;
;Isn't that a lot of checking, you might ask. Yes, it is. But you
;needn't include all of this checking into the ultimate compiled code.
;Remember, that development in Scheme is different than development in a
;language without an interpreter: Only after you have tested your
;routine interactively you'll compile it. So you'll arrange matters in
;such a way, that only interpreted code will check both the domain and
;the range, while compiled code will only test the former. Chicken
;allows to include interpreted-only code into an (eval-when (eval) ...)
;expression - a feature borrowed from Common Lisp -  which provides this
;distinction. Moreover, if you are really concerned about speed, you can
;avoid domain checking as well, compiling your code with the unsafe
;switch, because the actual checks will be done in assert epressions,
;which are ignored in unsafe code. But that's like driving without a
;security belt ....
;
;If you look at the above code, you'll note still some redundancy. So,
;like the short form of procedure definitions
;
;  (define (name . args) xpr . xprs)
;
;we'll supply a short form of define-with-contract as well, omitting
;the contract-line and the lambda-line:

;  (define-with-contract (quotient+remainder m n)
;    "integer division"
;    (domain:
;      (integer? m)
;      (not (negative? m))
;      (integer? n)
;      (positive? n)
;      (<= n m))
;    (range:
;      (with-results (q r)
;      (integer? q)
;      (integer? r)
;      (= (+ (* q n) r) m))
;    (let loop ((q 0) (r m))
;      (if (< r n)
;        (values q r)
;        (loop (add1 q) (- r n)))))
;
;State changing procedures
;-------------------------
;
;Now to the commands, procedures which change state. The state may be
;internal, e.g. a let before the defining lambda, or external, i.e. a
;hidden variable in the defining module. Or it might be encapsulated in
;required arguments of the routine.
;
;Now remember command-query-separation. To change the state of a routine
;and to return this state should be separate operations. In other words,
;usually a command is accompanied by a query. Hence a typical
;effect-checking clause would look like (state query change), where
;state is a variable to be bound by the query expression before the
;command call, and change is an expression describing how state is
;changed by the command. The actual check is done by the call
;(equal? change query), where now query is evaluated again after the
;command call. Note, that this clause is similar to a binding clause in
;do.
;
;But there are two problems with it. First, equal? is slow, and more
;specialized equality predicates seem preferable. This issue is not such
;important, since effects aren't checked in compiled code anyway.  But
;the other problem is important: What if command changes some state with
;some inexact computations? Than you can control the result only
;approximately. In other words, in some rare cases we need a fourth item
;in the effect clause above, an equality predicate.

;The whole effect check now consists of a list of such clauses, prefixed
;by the effect: keyword (effect: (state query change [equ?]) ...), where
;equ? is optional and set to equal?, if not given.

;Here is a trivial example:
;
;(define-with-contract adder!
;  (let ((state 0))
;    (contract (adder! arg)
;      "adds its argument to its state"
;      (domain: (number? arg))
;      (effect: (old state (+ old arg))))
;    (lambda (arg)
;      (set! state (+ state arg)))))

;Note that command-query-separation demands that there is either a range
;or an effect check, whence either a (range: ...) or an (effect: ...)
;expression.

;Example: An implementation of the single datatype 
;-------------------------------------------------
;Here is a simple, but realistic example, in which commands and queries
;are involved, the single datatype, an alternative to boxes.

;;;; predicate
;(define-with-contract (single? xpr)
;  "check, if xpr evaluates to a single"
;  (and (procedure? xpr)
;       (condition-case (eq? 'single (xpr (lambda (a b c) a)))
;         ((exn) #f))))
;
;;;; constructor
;(define-with-contract (single xpr)
;  "package the value of xpr into a single object"
;  (domain: (true? xpr))
;  (range: (single? result))
;  (lambda (sel)
;    (sel 'single xpr (lambda (new) (set! xpr new)))))
;
;;;; query
;(define-with-contract (single-state sg)
;  "returns the state of the single object sg"
;  (domain: (single? sg))
;  (range: (true? result))
;  (sg (lambda (a b c) b)))
;
;;;; command
;(define-with-contract (single-state! sg arg)
;  "replaces state of sg with arg"
;  (domain: (single? sg) (true? arg))
;  (effect: (state (single-state sg) arg))
;  ((sg (lambda (a b c) c)) arg))

;What to do with macros?
;-----------------------
;
;As for procedures
;
;  (define-syntax-with-contract name
;    contract-expression
;    transformer)
;
;should result in a checked syntax-definition including its automatic
;documentation.
;
;But macros are different from procedures in many aspects. First, they
;operate an forms only, i.e. they accept literal lists and return lists.
;Second, the transformer is evaluated at preprocessing time, that is,
;before runtime. So it has no access to runtime values. 
;
;What are transformers? In R5RS-Scheme, they are syntax-rules
;expressions. Well, syntax-rules matches a series of patterns against
;the macro's use and returns the template corresponding to the first
;matching pattern. On the other hand, a domain check for a macro could
;only test, if the macro code, which is a list, matches some patterns.
;In other words, the pattern-matching of syntax-rules could be
;considered as a domain-check, provided we are able to expose the
;admissible patterns for the documentation. Exposing those patterns
;would considerably improve the error message in case of failure as
;well.  After all, the standard error message
;
;  during expansion of (name ...) - no rule matches form: (name ...)
;
;is not of much help, unless we check the documentation, which, of
;course, must exist and be actual. The result of this considerations is,
;that the contract-expression doesn't need a domain clause, but the
;admissible patterns have to be exposed.

;But what about a range clause?  Does it make sense, to check the range
;of a macro-transformer?  Well, one could match the macro-expansion
;against some patterns as well. But I don't think that this is worth
;one's efforts, since one can always check that range with a simple call
;of the Chicken extension expand. Moreover, range: clauses aren't
;checked in compiled code. To sum up this discussion, the
;contract-expression of syntax-rules macros will simply be a
;documentation string. But define-syntax-with-contract will store the
;admissible patterns in the doclist parameter.
;
;All this applies to high-level syntax-rules macros only, not to raw
;low-level explicit- or implicit-renaming ones. The defining lambda
;expression can't export any patterns, because there are none. So we
;must supply them, as syntax-rules did. Hence we either implement two
;macros, er-macro-rules and ir-macro-rules, which look and work exactly
;like syntax-rules, or we provide the admissible patterns within the
;define-syntax-with-contract macro which checks the following
;(er|ir)-macro-transformer.
;
;Let's start with the first solution. Depending on the low-level system
;used we'll provide forms er-macro-rules and ir-macro-rules, which will
;do the job, namely
;
;  (er-macro-rules (%sym ...) (pat0 xpr0) (pat1 xpr1) ...)
;  (ir-macro-rules (sym ...) (pat0 xpr0) (pat1 xpr1) ...)
;
;where in the first case each sym is a symbol to be renamed and %sym
;represents its renamed version (any other one-character prefix will
;work as well) and in the second case each sym is protected against
;renaming. Consequently, in the first case the symbol list is usually
;very long, where in the second case it is usually empty (and it must
;be, if the macro should be hygienic).  Each xpr, xpr1, ... on the other
;hand, should expand into a template, usually a quasiquoted list, which
;can refer to the symbols in the symbol list via unquoting.
;
;To give a nontrivial example, the ordinary definition of a do-for macro
;with implicit renaming could look like this
;  
;  (define-syntax do-for
;    (ir-macro-rules ()
;      ((_ var (start stop . steps) . body)
;       (let ((step (if (null? steps) 1 (car steps))))
;         `(let ((stop ,stop))
;             (let loop ((,var ,start))
;                (unless (>= ,var stop)
;                   ,@body
;                   (loop (+ ,step ,var)))))))))
;  
;and a hygienic low-level or macro with explicit renaming like this
;
;  (define-syntax my-or
;    (er-macro-rules (%if %my-or)
;      ((_) #f)
;      ((_ arg . args)
;       `(,%if ,arg ,arg (,%my-or ,@args)))))
;  
;By the way, using these macros, (er-|ir-)macro-rules, we'll avoid the
;tedious work of destructuring the macro-code by hand and facilitate the
;renaming as well, if it is not already done implicitly. 
;
;Well, destructuring the macro-code isn't that simple. We could use one
;of the macros of the matchable package, match for example, but I prefer
;to implement my one ones, bind and bind-case for example, which this
;module exports as well, because they are of interest not only for the
;implementation of macros.
;
;Remember, that macro parameters in general are not simple lambda-lists
;as procedure parameters, but they may be deeply nested lambda-lists.
;This is the reason for the existence of the destructuring-bind macro in
;Common Lisp, which is used in the background of the defmacro
;implementation. My bind macro does the same, 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)), and
;
;  (bind-case xpr (pat0 xpr0) (pat1 xpr1) ...)
;
;will match xpr against pat0 pat1 ... in sequence and evaluate the
;expression paired with the first matching pattern. That latter macro
;will make the implementation of (er-|ir-)macro-rules easy.
;
;Now, having unified the definition of high- and low-level macros, we
;can process them in the same way. 
;
;Now to the second solution, providing the admissible pattern within
;the syntax-definition.
;
;For raw low-level (er|ir)-macro-transformers, the transformer should be
;preceeded in the checked syntax-definition by something like
;
;  (syntax-contract code [docstring])
;
;so that the long form of define-syntax-with-contract looks like the
;long form of define-with-contract. For that, syntax-contract needs not
;to be implemented as a macro of its own, because it will not be used in
;any other ways as in define-syntax-with-contract (contrary to the
;contract macro). It suffices to supply the name together with
;(er|ir)-macro-transformer in the list of literals.
;
;The short form of define-syntax-with-contract is easy insofar, as the
;contract-expression is simply a docstring. But this short form is
;possible only for transformers with one pattern only. There still
;remains the problem, what to do with the list of identifiers supplied
;as the first argument to syntax-rules and (er|ir)-macro-rules
;respectively. Our solution is to wrap the macro-body into one of
;
;  (literal syms . body)
;  (with-renamed syms . body)
;  (with-injected syms . body)
;
;which reflects the different meanings of this list, syms, and gives us
;a hint which macro-transformer to use, namely syntax-rules,
;er-macro-rules or ir-macro-rules respectively. Note, that in the first
;case syms contains symbols supplied by the client which should be
;treated literally, while in the other two cases syms are symbols
;provided by the supplier to be used within body.
;
;In sum, the syntax is one of
;
;  (define-syntax-with-contract (name . rest) [docstring] xpr)
;
;where xpr is one of (literal ...), (with-renamed ...),
;(with-injected ...)
;
;  (define-syntax-with-contract name [docstring] transformer)
;
;where transformer is either a syntax-rules, an er-macro-rules or an
;ir-macro-rules expression.

;or
;
;  (define-syntax-with-contract
;    (syntax-contract (name . rest) [docstring])
;    (macro-transformer handler))
;
;where syntax-contract is a literal and macro-transformer is literally
;either er- or ir-macro-transformer.

;Here is the implementation of the contracts module.

(module contracts
        (bind bind-case contract; matches?
         er-macro-rules ir-macro-rules
         define-with-contract define-syntax-with-contract
         doclist->dispatcher doclist print-doclist contracts)

(import scheme
        (only chicken print make-parameter void error
              condition-case eval-when assert case-lambda))

;Before we give the definition of the contract macro, we need two helper
;macros, the second of which does the actual checking with a meaningful
;error message in case of failure.  The first, collect, causes a lambda
;list of parameters to be transformed into the list of arguments when
;called. For example,
;
;  ((lambda (a b . c) (list a b c)) 1 2 3)
;
;will produce (1 2 (3)), while
;
;  ((lambda (a b . c) (collect (a b . c))) 1 2 3)
;
;results in (1 2 3).  It's needed, because all our checking macros will
;transform a procedure with arbitrary parameter lambda-list into a
;checked one with the same parameter lambda-list. In that latter
;procedure we can call (apply proc (collect args)) instead of (proc .
;args), which would only work for lists, not lambda-lists.

;;; (collect lambda-list)
;;; ---------------------
;;; helper macro returning the list of actual arguments
(define-syntax collect
  (syntax-rules ()
    ((_ ()) '())
    ((_ (a . b)) (cons a (collect b)))
    ((_ a)  (apply list a))))

;The second helper macro, check-em, uses a helper-procedure, pzip, which
;zips a flat pseudo-list of arguments, as, with a list of values, vs. It
;is implemented as a letrec in check-em so that it is available while
;preprocessing. The macro check-em returns a procedure, which checks
;each of its xpr ... expressions with assert and prints the offending
;xpr with a list of variable-value pairs in case of failure. This way
;you can trace what went wrong.

;;; (check-em name args msg xpr ...)
;;; --------------------------------
;;; helper macro returning a procedure which when called checks a number
;;; of assertions and prints a meaningful error message in case of
;;; failure
(define-syntax check-em
  (syntax-rules ()
    ((_ name args msg xpr ...)
     (letrec (
       (pzip (lambda (as vs)
               (cond
                 ((null? as) '())
                 ((pair? as)
                  (cons (list (car as) (car vs))
                        (pzip (cdr as) (cdr vs))))
                 (else (list (list as vs))))))
       )
       (lambda args
         (if (null? 'args)
           (begin
             (assert xpr name msg 'xpr)
             ...)
           (begin
             (assert xpr name msg 'xpr `(where ,@(pzip 'args (collect args)))) 
             ...)))))))

;The following three helper macros, domain, range and effect do the real work.
;They all accept a procedure argument and return that procedure argument
;checked, the same as the eventually exported contract macro will do.

;The first macro, domain-check, will simply use check-em on the arguments
;before calling the procedure proper.

;;; (domain-check name args . xprs)
;;; --------------------------------
;;; helper macro checking the domain of its procedure argument
;;; and returning a checked version.
(define-syntax domain-check
  (syntax-rules ()
    ((_ name args . xprs)
     (lambda (proc)
       (lambda args
         (apply (check-em 'name args "domain violation ..." . xprs)
                (collect args))
         (apply proc (collect args)))))))

;The second, range-check, should do the domain and range check for
;queries on the one hand and the invariant check for commands on the
;other. To do the first, it must have a list of assumptions and to do
;the second it should contain a list of result names, as well as message
;argument (since invariant checks are simply range checks with different
;error message). As you might expect, the domain check is done by the
;domain macro just defined.
;Remember, that in Scheme multiple results are produced by a values
;expression and referenced by call-with-values.

;;; (range-check name args (result0 result1 ...) (assumption ...) . xprs)
;;; ---------------------------------------------------------------------
;;; helper macro checking range and domain of its procedure argument
(define-syntax range-check
  (syntax-rules ()
    ;; range check: empty argument list, no assumptions, multiple results
    ((_ name () (result0 result1 ...) () . xprs)
     (lambda (proc)
       (lambda ()
         (call-with-values
           (lambda () (proc))
           (lambda (result0 result1 ...)
             (eval-when (eval)
               ((check-em 'name (result0 result1 ...)
                          "range violation ..." . xprs)
                result0 result1 ...))
             (values result0 result1 ...))))))
    ;; range and domain check: possibly non-empty argument pseudolist, multiple results
    ((_ name args (result0 result1 ...) (assumption ...) . xprs)
     (lambda (proc)
       (lambda args
         (call-with-values
           (lambda ()
             ;; check domain
             (apply ((domain-check name args assumption ...) proc)
                    (collect args)))
           (lambda (result0 result1 ...)
             ;; check range
             (eval-when (eval)
               (apply (check-em 'name (result0 result1 ... . args)
                                "range violation ..."
                                . xprs)
                      (collect (result0 result1 ... . args))))
             (values result0 result1 ...))))))))

;Note, that in the replacement text of this macro, you find the dotted
;list (result0 result1 ... . args) twice. This works in the
;macro-transformer. It would not work in the macro code, at least not in
;R5RS-Scheme.
;Note also, that the range check is wrapped into a call of eval-when, so
;that it will only be included in interpreted code.

;Now to the third essential helper macro, effect-check. It controls the
;effect of a command call.

;;; (effect-check name args (assumption ...) (state query change equ?) ...)
;;; ------------------------------------------------------------------------
;;; helper macro checking domain and side-effects of its command
;;; argument returning it checked.
;;; Binds state to the value of the query expression before the command
;;; call and checks if the change expression is equ? to the value of a
;;; second evaluation of query after the command call.
(define-syntax effect-check
  (syntax-rules ()
    ((_ name args (assumption ...) (state query change equ?) ...)
     (lambda (command)
       (lambda args
         ;; check domain
         (apply (check-em 'name args "domain violation ..." assumption ...)
                (collect args))
         ;; check state change
         (let ((state query) ...) ; query value before command call
           (command . args)
           (eval-when (eval)
             ;; evaluate query again and compare to change
             (apply (check-em 'name
                              (state ... . args)
                              (string-append 
                                "side-effect violation with "
                                (string-append ;(->string `(query ,query)) " ")
                                  (let ((o (open-output-string)))
                                    (display `(query ,query))
                                    (get-output-string o))
                                  " ")
                                ...
                                "...")
                              (equ? change query)
                              ...)
                    (collect (state ... . args))))))))))

;Note, that query ... can't be appended to the args pseudolist like
;state ..., because the latter are variables, but the former
;expressions. So we must add them to the message argument with ->string,
;or, equivalently, the relevant part of its implementation.
;Note also, that the effect check is wrapped into an eval-when, so that
;it is not executed in compiled code. The same happened with the range
;check above.

;Now, these three internal macros are used in the exported contract
;macro. This is implemented as an explicit renaming low-level macro for
;a simple reason: A high-level macro would need literally dozens of
;cases to cope with all possible calls. The procedural low-level macro
;could simply implement a loop to populate the variables results,
;assumptions, propositions and effects, which can be handed over to the
;three macros above. With the exceptions of the results variable, they
;are all initialized with the empty list. results, on the other hand, is
;initialized with (results: result), so that, if no results clause is
;given, it is assumed that there is only one return value named result.
;In other words, the macro not hygienic: It pollutes its local namespace
;with the symbol result.

;;; (contract (name . args) . xprs)
;;; -------------------------------
;;; where args is a lambda-list and xprs can contain any of the following
;;; expressions
;;; - a docstring
;;; - a list of domain checks (domain: assumption ...)
;;; - a list of range checks (range: proposition ...)
;;;   assuming the returned value is referenced by the name result
;;;   or (range: (with-results (result ...) proposition ...)
;;;   naming the returned values explicitly
;;; - a list of effect checks (effect: (state query change [equ?]) ...)
(define-syntax contract
  (er-macro-transformer
    (lambda (form rename compare?)
      (let (
        (name (caadr form))
        (args (cdadr form))
        (xprs (cddr form))
        (gproc (gensym 'proc))
        (%lambda (rename 'lambda))
        (%range (rename 'range))
        (%effect (rename 'effect))
        (%domain (rename 'domain))
        (%range-check (rename 'range-check))
        (%effect-check (rename 'effect-check))
        (%domain-check (rename 'domain-check))
        (%with-results (rename 'with-results))
        ) 
        (let loop (
          (xprs xprs)
          (results '(result))
          (assumptions '())
          (propositions '())
          (effects '())
          )
          (if (null? xprs)
            ;; apply the collected results
            (cond
              ;; nothing to check
              ((and (null? effects) (null? propositions) (null?  assumptions))
               `(,%lambda (,gproc) ,gproc))
              ;; check assumptions only
              ((and (null? effects) (null? propositions))
               `(,%lambda (,gproc)
                  ((,%domain-check ,name ,args ,@assumptions) ,gproc)))
              ;; check propositions and assumptions
              ((null? effects)
               `(,%lambda (,gproc)
                  ((,%range-check ,name ,args ,results
                            ,assumptions ,@propositions) ,gproc)))
              ;; check side effects and assumptions
              ((null? propositions)
                `(,%lambda (,gproc)
                   ((,%effect-check ,name ,args ,assumptions ,@effects) ,gproc)))
              (else
                (error 'contract "Either propositions or effects can be checked")))
            ;; collect the variables
            (let ((xpr (car xprs)))
              ;; xpr is either a string or a list starting with a keyword
              (cond
                ;; docstring: skip
                ((string? xpr)
                 (loop (cdr xprs)
                       results assumptions propositions effects))
                ;; domain expressions
                ((or (compare? (car xpr) domain:)
                     (compare? (car xpr) %domain))
                 (loop (cdr xprs)
                       results (cdr xpr) propositions effects))
                ;; range expressions
                ((or (compare? (car xpr) range:)
                    (compare? (car xpr) %range))
                 (let ((rest (cdr xpr)))
                   ;; now rest is either ((with-results results xpr ...))
                   ;; or (xpr ...)
                   (if (compare? (caar rest) %with-results)
                     (loop (cdr xprs)
                           (cadar rest) assumptions (cddar rest) effects)
                     (loop (cdr xprs)
                           results assumptions rest effects))))
                           ;results assumptions (cdr xpr) effects)))))
                ;; side effect expressions
                ((or (compare? (car xpr) effect:)
                    (compare? (car xpr) %effect))
                 (loop (cdr xprs)
                       results  assumptions propositions
                       ;; append equal? if no comparison is given
                       (map (lambda (x)
                              (if (= (length x) 3)
                                `(,@x equal?) ; ok
                                ;(append x '(equal?))  ; ok
                                x))
                            (cdr xpr))))))))))))


;The define-with-contract macro should reflect the two forms, either
;couple a name to a contract and a lambda-expression, or couple the form
;of a procedure-call with contract clauses followed by the expressions
;of the body of a lambda-expression. It's simple to dissect the latter
;two, because a contract clause is either a string or a list starting
;with one of the keywords results:, state:, domain:, range:,
;invariant: and effect:. This is tested by the internal predicate
;clause?

;;; (define-with-contract name contract proc)
;;; (define-with-contract (name . args) contract-clause ... . body)
;;; ---------------------------------------------------------------
;;; checks the procedure proc with contract, appends contract to the
;;; documentation (via doclist), and defines name as the checked
;;; procedure.
(define-syntax define-with-contract
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((rest (cdr form)))
        (if (symbol? (car rest)) ; name
          ;; long form:
          ;; we have to consider the case, that the contract and proc
          ;; are wrapped within a binding construct, as well
          (let (
            (body (cdr rest))
            (list-head 
              (lambda (lst upto)
                (let loop ((lst lst) (n upto) (head '()))
                  (if (zero? n)
                    (reverse head)
                    (loop (cdr lst)
                          (- n 1)
                          (cons (car lst) head))))))
            )
            (let (
              (head&tail
                (if (null? (cdr body))
                  ;; one element list containing a binding expression like
                  ;; (let decls contr proc) or (bind vars vals contr proc)
                  (let* ((binds (car body)) (split (- (length binds) 2)))
                    `(,(list-head binds split) ,(list-tail binds split)))
                  ;; two element list (contr proc)
                  `(() ,body)))
              )
              (let ((head (car head&tail)) (tail (cadr head&tail)))
                (let (
                  (contract-xpr (car tail))
                  (proc (cadr tail))
                  )
                  (let (
                    (name (caadr contract-xpr))
                    (args (cdadr contract-xpr))
                    (%begin (rename 'begin))
                    (%cdr (rename 'cdr))
                    (%cons (rename 'cons))
                    (%if (rename 'if))
                    (%define (rename 'define))
                    (%doclist (rename 'doclist))
                    )
                    `(,%begin
                       (,%doclist
                         (,%cons (,%cons ',name (,%cdr ',contract-xpr))
                                 (,%doclist)))
                       (,%if ,(null? head) ;(,%null? ,head)
                         (,%define ,name (,contract-xpr ,proc))
                         (,%define ,name (,@head (,contract-xpr ,proc))))))))))
          ;; short form: (_ (name . args) contract-clause ... . body)
          (let (
            (code (car rest))
            (xprs (cdr rest))
            (clause?
              (lambda (xpr)
                (or (string? xpr)
                    (and (list? xpr)
                         (not (null? xpr))
                         ;;(memp (lambda (x) (compare? (car xpr) x)) lst)
                         (let loop (
                           (lst (append '(domain: range: effect:)
                                        (map rename '(domain range effect))))
                           )
                           (cond
                             ((null? lst) #f)
                             ((compare? (car xpr) (car lst)) lst)
                             (else (loop (cdr lst)))))))))
            )
            (let (
              (name (car code))
              (args (cdr code))
              (split (lambda (lst)
                       (let loop ((clauses '()) (body lst))
                         (if (not (clause? (car body)))
                           (list (reverse clauses) body)
                           (loop (cons (car body) clauses) (cdr body))))))
              )
              (let (
                (pair (split xprs))
                (%define-with-contract (rename 'define-with-contract))
                (%contract (rename 'contract))
                (%lambda (rename 'lambda))
                )
                `(,%define-with-contract ,name
                   (,%contract ,code ,@(car pair))
                   (,%lambda ,args ,@(cadr pair)))))))))))
          

;Now we start with the definition of the macros ir-macro-rules and
;er-macro-rules, which allow to treat low-level-macros like high-level
;ones. We'll use a macro, bind-case, similar to match of the matchable
;package, and as a corollary for later use, the macro bind which does
;exactly what destructuring-bind in Common Lisp does. Both macros can
;destructure nested pseudolists only.  bind-case in turn needs the
;following helper-macro, which will not be exported as well. If it where
;defined as a function it had to be exported.
;
;;;(matches? pat xpr)
;;;------------------
(define-syntax matches?
  (syntax-rules ()
    ((_ () xpr)
     (null? xpr))
    ((_ (a . b) xpr)
     (condition-case
       (and (matches? a (car xpr))
            (matches? b (cdr xpr)))
       ((exn) #f)))
    ((_ a xpr) #t)))

(define-syntax one-matches?
  (syntax-rules ()
    ((_ xpr) #f)
    ((_ xpr pat) (matches? pat xpr))
    ((_ xpr pat0 pat1 ...)
     (if (matches? pat0 xpr)
       #t
       (one-matches? xpr pat1 ...)))))

;;; (bind-case xpr (pat0 . body0) (pat1 . body1) ...)
;;; -------------------------------------------------
;;; evaluates xpr and checks it its value matches pat0 pat1 ...
;;; executes the corresponding body of the first matching pat.
(define-syntax bind-case
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let (
        (xpr (cadr form))
        (pairs (cddr form))
        (destruc
          (lambda (pat xpr)
            (let recur ((pat pat) (xpr xpr))
              (cond
                ((null? pat) '())
                ((symbol? pat) `((,pat ,xpr)))
                ((pair? pat) (append (recur (car pat) `(car ,xpr))
                                     (recur (cdr pat) `(cdr ,xpr))))))))
        )
        (let (
          (msg (string-append
                 "match error: ~A doesn't match any of"
                 (apply string-append
                        (map (lambda (pat) " ~A") pairs)) "~%"))
          )
          (let loop ((pats (map car pairs)) (bodies (map cdr pairs)))
            (if (null? pats)
              `(error 'bind-case
                      (sprintf ,msg
                               ,xpr 
                               ,@(map (lambda (p) `',p)
                                      (map car pairs))))
              (let ((pat (car pats)) (body (car bodies)))
                `(if (matches? ,pat ,xpr)
                   (let ,(destruc pat xpr) ,@body)
                   ,(loop (cdr pats) (cdr bodies)))))))))))

;Having bind-case at our disposal, the implementation of
;(ir|er)-macro-rules is easy.
;Both macros are unhygienic by design, the first introduces the two
;symbols inject and compare? to its local scope, the second the only
;symbol compare?.

;;; (ir-macro-rules (sym ...) (pat0 xpr0) (pat1 xpr1) ...)
;;; ------------------------------------------------------
;;; where xpr0, xpr1, ... are expressions
;;; Checks the macro's use against a series of patterns, pat0, pat1 ...
;;; and executes the expression corresponding to the first matching
;;; pattern.
;;; This macro will mostly be imported with import-for-syntax, it is
;;; unhygienic by design, i.e. it pollutes the local namespace with
;;; symbols inject and compare?
(define-syntax ir-macro-rules
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((syms (cadr f)) (pairs (cddr f)))
        (let (
          (pats (map car pairs))
          (xprs (map cadr pairs))
          ;; unhygienic
          (inject (i 'inject))
          (compare? (i 'compare?))
          )
          `(ir-macro-transformer
             (lambda (form ,inject ,compare?)
               (let ,(map (lambda (sym) `(,sym (,inject ',sym)))
                           syms)
                 (bind-case form
                   ,@(map (lambda (pat xpr) `(,pat ,xpr))
                          pats xprs))))))))))

;;; (er-macro-rules (%sym ...) (pat0 xpr0) (pat1 xpr1) ...)
;;; -------------------------------------------------------
;;; where xpr0, xpr1, ... are expressions which generate the macro
;;; expansion.
;;; Checks the macro's use against a series of patterns, pat0, pat1 ...
;;; and returns the corresponding macro-expansion.
(define-syntax er-macro-rules
  (er-macro-transformer
  (lambda (f r c?)
    (let ((syms (cadr f)) (rules (cddr f)))
      (let (
        (pats (map car rules))
        (xprs (map cadr rules))
        (sym-cdr
          (lambda (%sym)
            (string->symbol 
              (substring
                (symbol->string %sym) 1))))
        (%let (r 'let))
        (%lambda (r 'lambda))
        (%bind-case (r 'bind-case))
        (%er-macro-transformer (r 'er-macro-transformer))
        (%form (r 'form))
        (%rename (r 'rename))
        )
        `(,%er-macro-transformer
           (,%lambda (,%form ,%rename compare?)
             (,%let ,(map (lambda (sym)
                            `(,sym (,%rename ',(sym-cdr sym))))
                          syms)
               (,%bind-case ,%form
                 ,@(map (lambda (pat xpr) `(,pat ,xpr))
                        pats xprs))))))))))

;;; (bind pat xpr . body)
;;; ----------------------
(define-syntax bind
  (syntax-rules ()
    ((_ pat xpr . body)
     (bind-case xpr (pat . body)))))

;Now to implement define-syntax-with-contract
;our first question is, what checks this macro should perform besides
;automatic documentation.

;A low-level macro handler is an ordinary function enclosed in an
;(er|ir)-macro-transformer, but this function operates on
;forms, i.e. it accepts a form as argument and returns another form,
;which happens to be an expression the compiler can understand. But
;since macro-transformation happens before compilation, in particular
;before runtime, the compiler has no access to runtime values, only to
;the raw forms. In other words, a domain check can only consist of
;matching the macro's use against the macro-code, which should be
;provided anyway. Consequently we don't need a domain: clause, the
;macro-code suffices.
;
;What about a range: clause? We could match the macro-expansion against
;some pattern again, but that isn't worth ones efforts. Remember, a
;range: clause is evaluated only in interpreted code, and in the
;interpreter we have the expand operator to inspect the macro-expansion.

;To sum up this discussion, define-syntax-with-contract needs only an
;optional docstring or - in case of raw low-level-macros - an
;additional (syntax-rules code [docstring]) parameter.

;Like define-with-contract, define-syntax-with-contract should
;automatically save documentation, and it should be available in a long
;and a short form. The long form should consist of a (syntax-contract
;...) expression followed by a raw low-level macro transformer. The
;syntax-contract checks if the macro's use matches the macro code, and
;if so executes the transformer. The short form contains the macro-code,
;eventually a docstring and the body of the macro-transformer. But there
;is a problem: The compiler must know, which macro-system to
;use. We solve this problem by wrapping the body into one of
;
;   (with-renamed syms ...)|(with-injected syms ...)|(literal syms ...)
;
;corresponding to (er-macro|ir-macro|syntax-) rules respectively.
;After all, we have designed it to mimic syntax-rules, and to check the
;admissible macro-codes like the latter.
;
;;; (define-syntax-with-contract name syntax-contract-xpr transformer)
;;; (define-syntax-with-contract name docstring rules-xpr)
;;; (define-syntax-with-contract (name . rest) docstring with-xpr)
;;; ------------------------------------------------------------------
;;; where transformer is a raw low-level macro-transformer,
;;; rules-xpr is one of syntax-rules, er-macro-rules,
;;; ir-macro-rules expression,
;;; and with-xpr is a with-renamed, a with-injected or a literal
;;; expression.
;;; Registers transformer, rules-xpr or with-xpr as a syntax-transformer
;;; under name, after having collected docstring and the transformer's
;;; pattern forms in (doclist).
(define-syntax define-syntax-with-contract
  (syntax-rules ()
    ;; long form with syntax-contract expression
    ((_ name (contract-key code)
             (transformer-key handler))
     (define-syntax-with-contract (contract-key code "")
                                  (transformer-key handler)))
    ((_ name (contract-key code docstring)
             (transformer-key handler))
     (syntax-contract-helper name
       (contract-key code docstring)
       (transformer-key handler)))
    ;; short form with rules
    ((_ (name . args) with-xpr)
     (define-syntax-with-contract name "" with-xpr))
    ((_ (name . args) docstring with-xpr)
     (rules-short-helper (name . args) docstring with-xpr))
    ;; long form with rules
    ((_ name transformer)
     (define-syntax-with-contract name "" transformer))
    ((_ name docstring transformer)
     (rules-long-helper name docstring transformer))))

;All what remains to be done is the implementation of the three helper
;macros.
;
;;;(syntax-contract-helper name (syntax-contract code docstring) transformer)
;;;--------------------------------------------------------------------------
;;; where transformer is an (er|ir)-macro-transformer expression
(define-syntax syntax-contract-helper
  (er-macro-transformer
    (lambda (f r c?)
      (let (
        (name (cadr f))
        (contract-xpr (caddr f))
        (transformer (cadddr f))
        )
        (let (
          (contract-key (car contract-xpr))
          (code (cadr contract-xpr))
          (docstring (caddr contract-xpr))
          (transformer-key (car transformer))
          (handler (cadr transformer))
          (%form (gensym 'form))
          (%rename (gensym 'rename))
          (%compare? (gensym 'compare?))
          (%if (r 'if))
          (%begin (r 'begin))
          (%doclist (r 'doclist))
          (%cons (r 'cons))
          (%list (r 'list))
          (%define-syntax (r 'define-syntax))
          (%lambda (r 'lambda))
          (%matches? (r 'matches?))
          (%error (r 'error))
          (%sprintf (r 'sprintf))
          )
          (if (c? contract-key (r 'syntax-contract))
            (if (or (c? transformer-key (r 'er-macro-transformer))
                    (c? transformer-key (r 'ir-macro-transformer)))
              `(,%begin
                 (,%doclist
                   (,%cons
                     (,%cons ',name (,%list ',code ,docstring))
                     (,%doclist)))
                 (,%define-syntax ,name
                   (,transformer-key
                     (,%lambda (,%form ,%rename ,%compare?)
                       (,%if (,%matches? ,code ,%form)
                         (,handler ,%form ,%rename ,%compare?)
                         (,%error 'syntax-contract
                                (,%sprintf "~A doesn't match ~A~%"
                                           ,%form ',code)))))))
              `(,%error 'define-syntax-with-contract
                        "neither an er- nor an ir-macro-trasnformer"
                        ,transformer-key))
            `(,%error 'define-syntax-with-contract
                      "not a syntax-rules expression"
                      ,contract-key)))))))

;;;(rules-short-helper (name . args) docstring with-xpr)
;;;-----------------------------------------------------
;;;where with-xpr is a (with-renamed|with-injected|literal) expression
(define-syntax rules-short-helper
  (er-macro-transformer
    (lambda (f r c?)
      (let (
        (code (cadr f))
        (docstring (caddr f))
        (with-xpr (cadddr f))
        )
        (let (
          (name (car code))
          (args (cdr code))
          (kind (car with-xpr))
          (syms (cadr with-xpr))
          (body (cddr with-xpr))
          )
          (let (
            (%begin (r 'begin))
            (%define-syntax-with-contract (r 'define-syntax-with-contract))
            (op
              (cond
                ((c? kind (r 'with-renamed))
                 (r 'er-macro-rules))
                ((c? kind (r 'with-injected))
                 (r 'ir-macro-rules))
                ((c? kind (r 'literal))
                 (r 'syntax-rules))
                (else
                  (error 'define-syntax-with-contract
                         "neither with-renamed nor with-injected nor literal"
                         'kind))))
            )
            `(,%define-syntax-with-contract ,name
               ,docstring
               (,op ,syms
                 ((_ ,@args) (,%begin ,@body))))))))))

;;;(rules-long-helper name docstring transformer)
;;;----------------------------------------------
;;;where transformer is an (syntax|er-macro|ir-macro)-rules expression
(define-syntax rules-long-helper
  (er-macro-transformer
    (lambda (f r c?)
      (let (
        (name (cadr f))
        (docstring (caddr f))
        (transformer (cadddr f))
        (%map (r 'map))
        (%cons (r 'cons))
        (%list (r 'list))
        (%doclist (r 'doclist))
        (%append (r 'append))
        (%begin (r 'begin))
        (%pat (r 'pat))
        (%cdr (r 'cdr))
        (%lambda (r 'lambda))
        (%define-syntax (r 'define-syntax))
        (%error (r 'error))
        (%syntax-rules (r 'syntax-rules))
        (%er-macro-rules (r 'er-macro-rules))
        (%ir-macro-rules (r 'ir-macro-rules))
        )
        (if (or (c? (car transformer) %syntax-rules)
                (c? (car transformer) %er-macro-rules)
                (c? (car transformer) %ir-macro-rules))
          (let (
            (pats (map car (cddr transformer)))
            )
            `(,%begin
               (,%doclist
                 (,%cons
                   (,%cons ',name
                           (,%append
                             (,%map (,%lambda (,%pat) (,%cons ',name (,%cdr ,%pat)))
                                    ',pats)
                             (,%list ,docstring)))
                   (,%doclist)))
               (,%define-syntax ,name
                  ,transformer))) ;bad error message for syntax-rules
          `(,%error 'define-syntax-with-contract
                    "neither syntax-rules nor (er-|ir-)macro-rules"
                    ',transformer))))))

;Now here is the parameter doclist mentioned in the introduction

;;; (doclist [alist])
;;; --------------------
;;; parameter, which produces an empty list to be populated by
;;; define-with-contract with the '(name [docstring] [contract]) 
;;; lists.
(define doclist
  (make-parameter '() (lambda (x)
                        (if (list? x)
                          x
                          '()))))

;Now the routine, which transforms the association list (doclist) into a
;dispatcher, i.e. function, which accepts a symbol and returns the
;corresponding association, saving the alist by the way.  Called with no
;arguments it returns the available symbols.
;In contrast to dispatcher, doclist->dispatecher can be implemented as a
;function.

;;; (doclist->dispatcher alist)
;;; ---------------------------
;;; transforms an association list, e.g. constructed by (doclist),
;;; into a dispatcher routine, which prints the association's values.
(define doclist->dispatcher
  (lambda (alist)
    (let ((syms (map car alist)))
      (case-lambda 
        (()
         syms)
        ((sym)
         (let ((found (assq sym alist)))
           (if found
             (if (and (null? (cddr found)) (procedure? (cadr found)))
               (cadr found)
               (for-each print (cdr found)))
             (begin
               (newline)
               (print "Not found: " sym)
               (print "Choose one of:")
               (print "--------------")
               (for-each print syms)))))))))


;;; (print-chars char n)
;;; --------------------
;;; print char n times
(define (print-chars char n)
  (if (= n 1)
    (display char)
    (begin
      (display char)
      (print-chars char (- n 1)))))

;;; (print-doclist)
;;; ---------------
;;; prints actual parameter (doclist) in readable form
(define print-doclist
  (lambda ()
    (let loop (
      ;(syms (sort (map car (doclist))
      ;            (lambda (x y)
      ;              (string< (symbol->string x) (symbol->string y)))))
      (syms (map car (doclist)))
      )
      (if (null? syms)
        (void)
        (let ((found (assq (car syms) (doclist))))
          (print (car syms))
          (print-chars #\- (string-length (symbol->string (car syms))))
          (newline)
          (for-each print (cdr found))
          (newline)
          (loop (cdr syms)))))))

;Last but not least here is the documentation which does by hand for
;the exported symbols in this module what define-with-contract and
;define-syntax-with-contract will do automatically in other modules.

;;; (contracts [sym])
;;; -----------------
;;; documentation procedure. Returns the list of available symbols if
;;; called with no arguments and i.a. the call structure of a macro, if
;;; called with the macro's name
(define contracts
  (doclist->dispatcher
    '((contract
        "checks the domain of its procedure argument proc"
        "and returns a checked version of proc"
        (contract (name . args)
          (domain: pre ...)
          (range: post ...)
          docstring)
        "where only (name . args) is obligatory and post is either a
(with-results (result ...) . body) expression or a check
on the predefined variable result, which references the 
only returned value"
        (contract (name . args)
          (domain: pre ...)
          (effect: (state query change equ?) ...)
          docstring)
        "where only (name . args) is obligatory, equ? is optional
and state references the result of query before the command call
and change compares state via equal? (or equ? if supplied) with
the result of query after the command call.")
      (define-with-contract
        "contract checked and documented version of define"
        (define-with-contract name
          (contract (name . args) . clauses)
          procedure)
        "checks each clause as defined in (contract ...) and returns procedure checked"
        (define-with-contract (name . args)
          clause0
          clause1
          ...
          . procedure-body)
        "checks each clause as defined in (contract ...) and returns
(lambda args . procedure-body) checked")
      (define-syntax-with-contract
        "contract checked and documented version of define-syntax"
        (define-syntax-with-contract name docstring rules-xpr)
        "where docstring is optional and rules-xpr is one of
syntax-rules, er-macro-rules ir-macro-rules"
        (define-syntax-with-contract name
          (syntax-contract (name . rest) docstring)
          transformer)
        "where docstring is optional and transformer is a
raw low-level (er|ir)macro-transformer"
        (define-syntax-with-contract (name . rest)
          docstring
          with-xpr)
        "where docstring is optional and with-xpr is one of
(literal syms . body) (with-renamed syms . body)
or (with-injected syms . body)")
      (er-macro-rules
        "explicit-renaming version of syntax-rules"
        (er-macro-rules (%sym ...) (pat0 xpr0) (pat1 xpr1) ...)
        "where %sym references sym renamed, xpr0 ... evaluate to
templates, which are usually backquoted expressions and the one
corresponding to the first matching pattern is evaluated")
      (ir-macro-rules
        "implicit-renaming version of syntax-rules"
        (ir-macro-rules (sym ...) (pat0 xpr0) (pat1 xpr1) ...)
        "where sym ... are injected symbols, xpr0 ... evaluate to
templates, which are usually backquoted expressions and the one
corresponding to the first matching pattern is evaluated")
      (bind
        "the same as destructuring-bind of Common Lisp"
        (bind pat xpr . body)
        "destructures the nested (pseudo-) list expression, xpr, along the pattern
pat, binds the pattern variables to corresponding subexpressions of xpr
and evaluates body in this context")
      (bind-case
        "lightweight version of matchable's match macro"
        (bind-case xpr (pat0 . body0) (pat1 . body1) ...)
        "matches xpr against pat0 pat1 ... in sequence and executes
body of the first matching pattern.")
      (doclist
        "parameter collecting documentation as an association list."
        "default is the empty list"
        (doclist)
        (doclist (cons (list 'name doc contract) (doclist))))
      (print-doclist
        "print actual parameter (doclist) in readable form"
        (print-doclist))
      (doclist->dispatcher
        "transforms an association list into a dispatcher"
        "i.e. a procedure returning the association of a symbol"
        "or all available symbols when called with no arguments."
        (doclist->dispatcher lst)))))

) ; module contracts