;Author: Juergen Lorenz ; ju (at) jugilo (dot) de

;
; Copyright (c) 2017-2018, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#|[
This library provides two modules, one with helper routines to be
imported for syntax into the other with macros, which facilitate the
writing of procedural-macros.

Chicken provides two procedural macro-systems, implicit and explicit
renaming macros. In both you have to destructure the use-form yourself
and provide for the renaming or injecting of names which could or should
be captured. Destructuring can be automated with the bind macro -- a
simplified version of the equally named macro in the bindings library --
and renaming resp. injecting can be almost automated with the help of
either the macro with-mapped-symbols or two macro-generators, which
replace the rename resp. inject parameter of the transformer with a
prefix symbol. Note, that bind or with-mapped-symbols must be used
for-syntax, if used in a macro body for destructuring or
renaming/injecting.

Usually an ambituous explicit renaming macro contains a long let
defining the renamed symbols -- usually prefixed with some fixed symbol
constant like % -- which is then executed in the macro's body by
unquoting it. Both methods create the let automatically.

Here are two simple examples, one the swap! macro, using
define-er-macro-transformer and with-mapped-symbols, the other numeric if,
using define-er-macro and and explicit prefix, %.
In the latter case, the macro searches its body for symbols starting
with this prefix, collects them in a list, removes duplicates and adds
the necesary let with pairs of the form

  (%name (rename 'name)

to the front of the body. In other words it does what you usually do by
hand.

  (define-er-macro-transformer (swap! form rename compare?)
    (let ((x (cadr form)) (y (caddr form)))
      (with-mapped-symbols rename % (%tmp %let %set!)
        `(,%let ((,%tmp ,x))
           (,%set! ,x ,y)
           (,%set! ,y ,%tmp)))))

  (define-er-macro (nif form % compare?)
    (bind (_ xpr pos zer neg) form
      `(,%let ((,%result ,xpr))
         (,%cond
           ((,%positive? ,%result) ,pos)
           ((,%negative? ,%result) ,neg)
           (,%else ,zer)))))

Note, that one of the standard arguments of an er-macro-transformer,
rename, is replaced by the prefix, which characterize the symbols in the
body to be renamed. The other arguments, form and compare?, remain
untouched.


For implicit renaming macros the list of injected symbols is usually,
but not allways, short, even empty for nif. Of course, the generated let
replaces rename with inject in this case. 
For example, here is a version of alambda, an anaphoric version of
lambda, which injects the name self:

  (define-ir-macro (alambda form % compare?)
    (bind (_ args xpr . xprs) form
      `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
         ,%self)))

]|#

(module basic-macro-helpers ;*
  (basic-macro-helpers pseudo-list pseudo-list? pseudo-list-of
   pseudo-null? pseudo-length pseudo-head pseudo-tail pseudo-ref
   pseudo-sentinel pseudo-flatten
   remove-duplicates adjoin filter sym-prepends? sym-tail)

  (import scheme
          (only chicken case-lambda assert print error))

(define (pseudo-list sentinel . args)
  (let loop ((args args))
    (if (null? args)
      sentinel
      (cons (car args) (loop (cdr args))))))

(define (pseudo-list? xpr)
  (not (list? xpr)))
 ; #t)

(define (my-conjoin . preds)
  (let recur ((preds preds))
    (lambda (xpr)
      (cond
        ((null? preds) #t)
        (((car preds) xpr)
         ((recur (cdr preds)) xpr))
        (else #f)))))

(define (pseudo-list-of . preds)
  (let ((ok? (apply my-conjoin preds)))
    (lambda (xpr)
      (if (pair? xpr)
        (and (ok? (car xpr))
             ((pseudo-list-of ok?) (cdr xpr)))
        (ok? xpr)))))

(define (pseudo-null? xpr)
  (not (pair? xpr)))

(define (pseudo-length pl)
;; sentinel doesn't count in length!
  (if (pair? pl)
    (+ 1 (pseudo-length (cdr pl)))
    0))

(define (pseudo-sentinel pl)
  (if (pair? pl)
    (let ((rest (cdr pl)))
      (if (pair? rest)
        (pseudo-sentinel rest)
        rest))
    pl))

(define (pseudo-ref pl n)
  (assert (< n (pseudo-length pl)))
  (cond
    ((not (pair? pl)) pl)
    ((= n 0) (car pl))
    (else
     (pseudo-ref (cdr pl) (- n 1)))))

(define pseudo-tail
  (case-lambda
    ((pl n)
     (assert (<= n (pseudo-length pl)))
     (let loop ((pl pl) (n n))
       (cond
         ((not (pair? pl)) pl)
         ((= n 0) pl)
         (else
          (loop (cdr pl) (- n 1))))))
    ((pl)
     (pseudo-tail pl (pseudo-length pl)))))

(define pseudo-head
  (case-lambda
    ((pl n)
     (assert (<= n (pseudo-length pl)))
     (if (not (pair? pl))
       '()
       (let loop ((k 0) (pl pl) (result '()))
         (if (= k n)
           (reverse result)
           (loop (+ k 1) (cdr pl) (cons (car pl) result))))))
    ((pl)
     (pseudo-head pl (pseudo-length pl)))))

(define (pseudo-flatten tree)
  ; imported flatten doesn't work with pseudo-lists
  (let loop ((tree tree) (result '()))
    (cond
      ((pair? tree)
       (loop (car tree) (loop (cdr tree) result)))
      ((null? tree) result)
      (else
        (cons tree result)))))

(define (remove-duplicates lst)
  (let loop ((lst lst) (result '()))
    (if (null? lst)
      (reverse result)
      (loop (cdr lst) (adjoin (car lst) result)))))

(define (adjoin obj lst)
  (if (member obj lst) lst (cons obj lst)))

(define (filter ok? lst)
  (let loop ((lst lst) (result '()))
    (cond
      ((null? lst) (reverse result))
      ((ok? (car lst))
       (loop (cdr lst) (cons (car lst) result)))
      (else
        (loop (cdr lst) result)))))

(define (sym-prepends? pre sym)
  (assert (symbol? pre))
  (assert (symbol? sym))
  (let ((spre (symbol->string pre))
        (ssym (symbol->string sym)))
    (let ((prelen (string-length spre))
          (symlen (string-length ssym)))
      (and (< prelen symlen)
           (equal? (string->list spre)
                   (string->list (substring ssym 0 prelen)))))))

(define (sym-tail pre sym)
  (let ((spre (symbol->string pre))
        (ssym (symbol->string sym)))
    (let ((prelen (string-length spre))
          (symlen (string-length ssym)))
      (string->symbol (substring ssym prelen)))))

;;; (basic-macro-helpers sym ..)
;;; ----------------------------
;;; documentation procedure.
(define basic-macro-helpers
  (let ((alst '(
    (pseudo-list
      procedure:
        (pseudo-list sentinel . args)
        "creates a new pseudo-list from args"
        "and sentinel")
    (pseudo-list?
      procedure:
        (pseudo-list? xpr)
        "is xpr a pseudo-list?"
        "i.e. not a list?")
    (pseudo-list-of
      procedure:
      (pseudo-list-of . preds)
      "returns a unary predicate, which checks"
      "if its argument passes each predicate in preds")
    (pseudo-null?
      procedure:
        (pseudo-null? xpr)
        "is xpr pseudo-null?, i.e. not a pair")
    (pseudo-length
      procedure:
        (pseudo-length pl)
        "length of a pseudo-list pl"
        "the sentinel doesn't count")
    (pseudo-sentinel
      procedure:
        (pseudo-sentinel pl)
        "returns the sentinel of a pseudo-list, i.e '()"
        "in the case of a proper list")
    (pseudo-ref
      procedure:
        (pseudo-ref pl n)
        "returns the nth item of pl, where n is less than"
        "pl's pseudo-length")
    (pseudo-tail
      procedure:
        (pseudo-tail pl n)
        (pseudo-tail pl)
        "returns the tail of pl starting with index n, where n is"
        "less than or equal to pl's pseudo-length,"
        "if n is not provided, pl's pseudo-length is assumed")
    (pseudo-head
      procedure:
        (pseudo-head pl n)
        (pseudo-head pl)
        "returns the head of pl up to but excluding index n,"
        "where n is less than or equal to pl's pseudo-length;"
        "if n is not provided, pl's pseudo-length is assumed")
    (pseudo-flatten
      procedure:
        (pseudo-flatten tree)
        "flattens the nested pseudo-list tree to a proper list")
    (remove-duplicates
      procedure:
        (remove-duplicates lst)
        "removes duplicates of a proper list")
    (adjoin
      procedure:
        (adjoin obj lst)
        "adds obj to a proper list, provided, it isn't already there")
    (filter
      procedure:
        (filter ok? lst)
        "filters a proper list by means of a predicate ok?")
    (sym-prepends?
      procedure:
        (sym-prepends? pre sym)
        "checks, if the symbol sym starts with the symbol pre")
    (sym-tail
      procedure:
        (sym-tail pre sym)
        "returns the tail of the symbol sym by"
        "stripping its prefix pre")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'basic-macros
                  "not exported" sym)))))))
) ; module basic-macro-helpers

(module basic-macros ;*
  (define-syntax-rule define-er-macro-transformer define-ir-macro-transformer
   define-er-macro define-ir-macro bind bind-case once-only basic-macros
   with-mapped-symbols with-gensyms)
  (import scheme basic-macro-helpers
          (only chicken condition-case case-lambda print error))
  (import-for-syntax; basic-macro-helpers)
                      (except basic-macro-helpers
                              pseudo-list
                              pseudo-length
                              pseudo-sentinel
                              pseudo-list?))

#|[Let's start with a one syntax-rule]|#

;;; (define-syntax-rule (name . args) xpr . xprs)
;;; (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
;;; ---------------------------------------------------------------
;;; simplyfies define-syntax in case there is only one rule
(define-syntax define-syntax-rule
  (syntax-rules (keywords)
    ((_ (name . args)
        (keywords key ...) xpr . xprs)
     (define-syntax name
       (syntax-rules (key ...)
         ((_ . args) xpr . xprs))))
    ((_ (name . args) xpr . xprs)
     (define-syntax name
       (syntax-rules ()
         ((_ . args) xpr . xprs))))))

#|[
Let's start with some helpers which might be occasionally useful
]|#

;;; (define-er-macro-transformer form rename compare?)
;;; --------------------------------------------------
;;; wrapper around er-macro-transformer
(define-syntax define-er-macro-transformer
  (syntax-rules ()
    ((_ (name form rename compare?) xpr . xprs)
     (define-syntax name
       (er-macro-transformer
         (lambda (form rename compare?) xpr . xprs))))))

;;; (define-ir-macro-transformer form inject compare?)
;;; --------------------------------------------------
;;; wrapper around ir-macro-transformer
(define-syntax define-ir-macro-transformer
  (syntax-rules ()
    ((_ (name form inject compare?) xpr . xprs)
     (define-syntax name
       (ir-macro-transformer
         (lambda (form inject compare?) xpr . xprs))))))

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

  (bind (x (y z)) '(1 (2 3)) (list x y z))

will result in '(1 2 3)
]|#

;;; (do-bind pat seq xpr . xprs)
;;; ----------------------------
;;; internal helper to be wrapped in bind:
;;; binds pattern variables of pat to corresponding subexpressions of
;;; seq and executes body xpr . xprs in this context.
(define-er-macro-transformer (do-bind form rename compare?)
;(define-syntax do-bind
;  (er-macro-transformer
;    (lambda (form rename compare?)
  (let ((pat (cadr form))
        (seq (caddr form))
        (xpr (cadddr form))
        (xprs (cddddr form))
        (%_ (rename '_))
        (%if (rename 'if))
        (%seq (rename 'seq))
        (%and (rename 'and))
        (%let (rename 'let))
        (%not (rename 'not))
        (%pair? (rename 'pair?))
        (%begin (rename 'begin))
        (%error (rename 'error))
        (%equal? (rename 'equal?))
        (%pseudo-ref (rename 'pseudo-ref))
        (%pseudo-tail (rename 'pseudo-tail)))
    (let ((body `(,%begin ,xpr ,@xprs)))
      (letrec (
        (no-dups?
          (lambda (lst)
            (call-with-current-continuation
              (lambda (cc)
                (let loop ((lst lst) (result '()))
                  (if (null? lst)
                    #t
                    (loop (cdr lst)
                          ;(if (memq (car lst) result)
                          ;; keywords can be used as literals
                          (if (and (not (keyword? (car lst)))
                                   (memq (car lst) result))
                            (cc #f)
                            (cons (car lst) result)))))))))
        (destructure
          (lambda (pat seq)
            (let ((len (let loop ((pat pat) (result 0))
                         (cond
                           ((null? pat) result)
                           ((pair? pat)
                            (loop (cdr pat) (+ 1 result)))
                           (else result)))))
              (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
                (if (= k len)
                  (let ((sentinel
                          ;last dotted item or '()
                          (let loop ((result pat) (k len))
                            (if (zero? k)
                              result
                              (loop (cdr result) (- k 1))))))
                    (cond
                      ((null? sentinel)
                       (values pairs literals
                               (cons ;`(,%pseudo-null?
                                     ;   (,%pseudo-tail ,seq ,k))
                                     `(,%not
                                        (,%pair?
                                          (,%pseudo-tail ,seq ,k)))
                                     tails)))
                      ((symbol? sentinel)
                       (if (compare? sentinel %_)
                         (values pairs literals tails)
                         (values (cons (list sentinel
                                             `(,%pseudo-tail ,seq ,k))
                                       pairs)
                                 literals tails)))
                      (else
                        (values pairs
                                (cons `(,%equal? ',sentinel
                                                 (,%pseudo-tail ,seq ,k))
                                      literals)
                                tails))))
                  (let ((item (pseudo-ref pat k)))
                    (cond
                      ((and (symbol? item) (not (keyword? item)))
                       (if (compare? item %_)
                         (loop (+ k 1) pairs literals tails)
                         (loop (+ k 1)
                               (cons (list item `(,%pseudo-ref ,seq ,k)) pairs)
                               literals
                               tails)))
                      ((pair? item)
                       (call-with-values
                         (lambda ()
                           (destructure item `(,%pseudo-ref ,seq ,k)))
                         (lambda (ps ls ts)
                           (loop (+ k 1)
                                 (append ps pairs)
                                 (append ls literals)
                                 (append ts tails)))))
                      (else ;(atom? item) ; literal 
                        (loop (+ k 1)
                              pairs
                              (cons `(,%equal? ',item
                                               (,%pseudo-ref ,seq ,k))
                                    literals)
                              tails))
                      )))))))
        )
        (call-with-values
          (lambda () (destructure pat seq))
          (lambda (pairs literals tails)
            (if (no-dups? (map car pairs))
              `(,%if (,%and ,@tails)
                     (,%if (,%and ,@literals)
                           (,%let ,pairs ,body)
                           (,%error 'bind "literals don't match" ',literals))
                     (,%error 'bind "length mismatch" ',tails))
              `(,%error 'bind
                        "duplicate pattern variables"
                        ',(map car pairs)))))
          ))));))

;;;; (bind pat seq xpr . xprs)
;;;; (bind pat seq (where (x x? ...) ...) xpr . xprs)
;;;; ------------------------------------------------
;;;; binds pattern variables of pat to corresponding subexpressions of
;;;; seq and executes body xpr . xprs in this context
(define-syntax bind
  (syntax-rules (where)
    ((_ pat seq (where (x x? ...) ...) xpr . xprs)
     (let ((%seq seq))
       (do-bind pat %seq
         (if (and (and (x? x) ...) ...)
           (begin xpr . xprs)
           (error 'bind "where-clause violated")))))
    ((_ pat seq xpr . xprs)
     (let ((%seq seq))
       (do-bind pat %seq xpr . xprs)))))

;;; (bind-case seq (pat xpr . xprs) ...)
;;; (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-ir-macro-transformer (bind-case form inject compare?)
  (let ((seq (cadr form))
        (rules (cddr form))
        (insert-where-clause
          (lambda (rule)
            (if (and (pair? (cadr rule))
                     (compare? (caadr rule) 'where))
              rule
              `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
    (let ((rules (map insert-where-clause rules))
          (rule->bind
            (lambda (rule)
              `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
      (let loop ((binds (map rule->bind rules)) (pats '()))
        (if (null? binds)
           `(error 'bind-case "no match"
                   ,seq
                   ',(reverse pats))
           `(condition-case ,(car binds)
              ((exn)
               ,(loop (cdr binds)
                      (cons (list (cadar binds) (car (cdddar binds)))
                            pats)))))))))
; the procedural version above improves the error message
;(define-syntax bind-case
;  (syntax-rules ()
;    ((_ seq)
;     (error 'bind-case "no match, possibly caused by fenders, for" seq))
;    ((_ seq (pat (where . fenders) xpr . xprs))
;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
;       ((exn) (bind-case seq))))
;    ((_ seq (pat xpr . xprs))
;     (bind-case seq (pat (where) xpr . xprs)))
;    ((_ seq clause . clauses)
;     (condition-case (bind-case seq clause)
;       ((exn) (bind-case seq . clauses))))
;    ))

;;; (once-only (x ....) xpr ....)
;;; -----------------------------
;;; macro-arguments x .... are only evaluated once and from left to
;;; right in the body xpr ....
;;; The code is more or less due to
;;; P. Seibel, Practical Common Lisp, p. 102
;(define-syntax once-only
;  (er-macro-transformer
;    (lambda (form rename compare?)
(define-er-macro-transformer (once-only form rename compare?)
  (let ((names (cadr form))
        (body (cons (caddr form) (cdddr form)))
        (%let (rename 'let))
        (%list (rename 'list))
        )
    (let ((syms (map rename names)))
      `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) syms)
         `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
                               syms names))
            ,(,%let ,(map (lambda (n g) `(,n ,g))
                        names syms)
               ,@body))))));))
;(define-ir-macro-transformer (once-only form inject compare?)
;  (let ((names (cadr form))
;        (body (cons (caddr form) (cdddr form))))
;    (let ((gensyms (map (lambda (x) (gensym)) names)))
;      `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
;         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
;                             gensyms names))
;            ,(let ,(map (lambda (n g) `(,n ,g))
;                        names gensyms)
;               ,@body))))))
;

;;; (define-macro-with (name form prefix compare? transformer) xpr . xprs)
;;; ----------------------------------------------------------------------
;;; internal helper
(define-syntax define-macro-with
  (er-macro-transformer
    (lambda (form rename compare?)
      (let (
        (header (cadr form))
        (body (cons (caddr form) (cdddr form)))
        )
        (let (
          (name (car header))
          (frm (cadr header))
          (pre (caddr header))
          (cmp? (cadddr header))
          (transformer (car (cddddr header)))
          (ren 'process)
          (%let (rename 'let))
          (%lambda (rename 'lambda))
          (%define-syntax (rename 'define-syntax))
          )
          `(,%define-syntax ,name
             (,transformer
               (,%lambda (,frm ,ren ,cmp?)
                 (,%let ,(map (lambda (sym)
                                `(,sym (,ren ',(sym-tail pre sym))))
                              (remove-duplicates
                                (filter (lambda (sym)
                                          (and (symbol? sym)
                                               (sym-prepends? pre sym)))
                                        (pseudo-flatten body))))
                   ,@body)))))))))

;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
;;; ---------------------------------------------------------------
;;; defines an explicit-renaming macro name with use-form form,
;;; automatically renaming symbols starting with inject-rpefix
(define-syntax define-er-macro
  (syntax-rules ()
    ((_ (name form rename-prefix compare?) xpr . xprs)
     (define-macro-with
       (name form rename-prefix compare? er-macro-transformer)
       xpr . xprs))))

;;; (define-ir-macro (name form inject-prefix compare?) xpr . xprs)
;;; ---------------------------------------------------------------
;;; defines an implicit-renaming macro name with use-form form,
;;; automatically injecting symbols starting with inject-rpefix
(define-syntax define-ir-macro
  (syntax-rules ()
    ((_ (name form inject-prefix compare?) xpr . xprs)
     (define-macro-with
       (name form inject-prefix compare? ir-macro-transformer)
       xpr . xprs))))

;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
;;; -------------------------------------------------------------
;;; binds a series of prefixed names, prefix-x ....
;;; to the images of the original names, x ...., under mapper
;;; and evaluates xpr .... in this context
(define-syntax with-mapped-symbols
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((mapper (cadr form))
            (prefix (caddr form))
            (syms (cadddr form))
            (xpr (car (cddddr form)))
            (xprs (cdr (cddddr form)))
            (%let (rename 'let)))
        `(,%let ,(map (lambda (s)
                        `(,s (,mapper ',(sym-tail prefix s))))
                      syms)
           ,xpr ,@xprs)))))

;;; (with-gensyms (name ....) xpr ....)
;;; -----------------------------------
;;; binds name ... to (gensym 'name) ... in body xpr ...
(define-syntax with-gensyms
  (ir-macro-transformer
    (lambda (form inject compare?)
      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
         ,@(cddr form)))))


;;; (basic-macros sym ..)
;;; ---------------------
;;; documentation procedure.
(define basic-macros
  (let ((alst '(
    (define-syntax-rule
      macro:
       (define-syntax-rule (name . args) xpr . xprs)
       (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
       "simplyfied version of syntax-rules,"
       "if there is only one rule")
    (bind
      macro:
      (bind pat seq (where fender ...) .. xpr ....)
      "a variant of Common Lisp's destructuring-bind"
      "where pat and seq are a nested pseudo-lists and"
      "optional fenders of the form (x x? ...) are checked"
      "before evaluating the body xpr ...")
    (bind-case
      macro:
      (bind-case seq (pat (where fender ...) .. xpr ...) ....)
      "matches a nested pseudo-list seq against nested pseudo-lists"
      "pat ... with optional fenders ... in sequence in a case regime")
    (once-only
      macro:
      (once-only (x ....) xpr ....)
      "arguments x ... are evaluated only once and"
      "from left to right in the body xpr ....")
    (define-er-macro-transformer
      macro:
      (define-er-macro-tansformer name form rename compare?)
      "wrapper around er-macro-transformer")
    (define-ir-macro-transformer
      macro:
      (define-ir-macro-tansformer name form inject compare?)
      "wrapper around ir-macro-transformer")
    (define-er-macro
      macro:
      (define-er-macro name form rename-prefix compare?)
      "creates an explicit-renaming macro, where all symbols"
      "starting with rename-prefix are renamed automatically")
    (define-ir-macro
      macro:
      (define-ir-macro name form inject-prefix compare?)
      "creates an implicit-renaming macro, where all symbols"
      "starting with inject-prefix are injected automatically")
    (with-mapped-symbols
      macro:
      (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
      "binds a series of prefixed names, prefix-x ...."
      "to the images of the original names, x ...., under mapper"
      "and evaluates xpr .... in this context")
    (with-gensyms
      macro:
      (with-gensyms (x ....) xpr ....)
      "generates a series of gensyms x .... to be used in body xpr ...")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'basic-macros
                  "not exported" sym)))))))

) ; module basic-macros