; Author: Juergen Lorenz ; ju (at jugilo (dot) de
;
; Copyright (c) 2013-2019, 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.

#|[
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)))

]|#
(declare (unit procedural-macros))

(module basic-macros
  (define-syntax-rule
   define-er-macro-transformer
   define-ir-macro-transformer
   define-er-macro
   define-ir-macro
   once-only
   with-mapped-symbols
   with-gensyms
   basic-macros
   )
  (import scheme
          ;(only bindings bind-case)
          (only (chicken condition) condition-case)
          (only (chicken base) case-lambda print error))
  (import-for-syntax (only bindings bind-case))

#|[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))))))

;;; (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)))
        (pseudo-flatten
          (lambda (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))))))
        (adjoin 
          (lambda (obj lst)
            (if (member obj lst) lst (cons obj lst))))
        (sym-tail
          (lambda (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))))))
        (sym-prepends?
          (lambda (pre 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))))))))
        )
        (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))
          (flat-body (pseudo-flatten body))
          (remove-duplicates
            (lambda (lst)
              (let loop ((lst lst) (result '()))
                (if (null? lst)
                  (reverse result)
                  (loop (cdr lst) (adjoin (car lst) result))))))
          )
          `(,%define-syntax ,name
             (,transformer
               (,%lambda (,frm ,ren ,cmp?)
                 (,%let ,(map (lambda (sym)
                                `(,sym (,ren ',(sym-tail pre sym))))
                              (remove-duplicates
                                (compress
                                  (map (lambda (sym)
                                         (and (symbol? sym)
                                              (sym-prepends? pre sym)))
                                       flat-body)
                                  flat-body)))
                                ;(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))
            (sym-tail
              (lambda (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)))))))
        `(,%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

#|[
This module will provide some macro-writing macros, in particular
macro-rules and define-macro, based on explicit- and implicit-renaming.
The syntax of macro-rules mimics that of syntax-rules, except that it
allows for injected symbols before the keyword list and the templates
are usually quasiquoted lists. Since we use bind-case from the bindings
egg, this library accepts wildcards, non-symbol literals and fenders.
]|#

(module procedural-macros
  (procedural-macros
    define-macro
    (macro-rules bind-case)
    macro-let
    macro-letrec
    ;basic-macros
    once-only
    define-ir-macro-transformer
    define-er-macro-transformer
    define-ir-macro
    define-er-macro
    with-mapped-symbols
    with-gensyms)
  
  (import scheme
          basic-macros
          (only (chicken base) print error case-lambda)
          (only bindings bind-case))
  (import-for-syntax (only (chicken base) compress))

#|[
The workhorse of the library is the following macro, a procedural
version of syntax-rules, but without its limitations.
]|#

;;; (macro-rules sym ... (key ...) (pat tpl) ...)
;;; (macro-rules sym ... (key ...) (pat (where fender ...) tpl) ...)
;;; ----------------------------------------------------------------
;;; where sym ... are injected non-hygienig symbols, key ... are
;;; additional keywords, pat ....  are nested lambda-lists without
;;; spezial meaning of ellipses and tpl .... usually evaluate to
;;; quasiquoted templates. The optional fenders belong to the pattern
;;; matching process.
(define-er-macro-transformer (macro-rules f r c?)
  (let (
    (f* (let loop ((tail (cdr f)) (head '()))
          (if (symbol? (car tail))
            (loop (cdr tail) (cons (car tail) head))
            (cons head tail))))
    (%x (r 'x))
    (%let (r 'let))
    (%form (r 'form))
    (%where (r 'where))
    (%lambda (r 'lambda))
    (%inject (r 'inject))
    (%compare? (r 'compare?))
    (%bind-case (r 'bind-case))
    (%ir-macro-transformer (r 'ir-macro-transformer))
    )
    (let ((syms (car f*))
          (keys (cadr f*))
          (rules (cddr f*))
          (pseudo-flatten
            (lambda (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))))))
          )
      (let* ((pats (map car rules))
             (fpats (map pseudo-flatten pats))
             (kpats (map (lambda (fp)
                           ;(filter (lambda (x)
                           ;          (memq x keys))
                           ;        fp))
                           (compress
                             (map (lambda (x) (memq x keys)) fp)
                             fp))
                         fpats))
             ;; compare? keywords with its names
             (key-checks
               (map (lambda (kp)
                      (map (lambda (p s)
                             `(,p (,%lambda (,%x)
                                            (,%compare? ,%x ,s))))
                           kp
                           (map (lambda (x) `',x)
                                kp)))
                    kpats))
             ;; prepare where clause for each rule
             ;; to check keys
             (all-rules (map (lambda (rule checks)
                               (let ((second (cadr rule)))
                                 (if (and (pair? second)
                                          (c? (car second) %where))
                                   `(,(car rule)
                                      (,%where ,@(cdr second) ,@checks)
                                      ,@(cddr rule))
                                   `(,(car rule)
                                      (,%where ,@checks)
                                      ,@(cdr rule)))))
                             rules key-checks)))
        `(,%ir-macro-transformer
           (,%lambda (,%form ,%inject ,%compare?)
             (,%let ,(map (lambda (s)
                       `(,s (,%inject ',s)))
                     syms)
               (,%bind-case ,%form
                            ,@all-rules))))))))

#|[
And now a procedural version of our old friend, define-macro,
which is hygienic, if now injections are provided.
]|#

;;; (define-macro (name . args)
;;;   (where (x . xs) ...)
;;;   xpr . xprs)
;;; -----------------------------------  
;;; where xs is either a list of predicates, thus providing fenders,
;;; or a singleton containing one of the symbols keyword or injection
;;; to provide keyword arguments or nonhygienic macros 
(define-er-macro-transformer (define-macro form rename compare?)
  (let ((code (cadr form))
        (xpr (caddr form))
        (xprs (cdddr form))
        (%where (rename 'where))
        (%keyword (rename 'keyword))
        (%injection (rename 'injection))
        (%define-macro (rename 'define-macro))
        (%macro-rules (rename 'macro-rules))
        (%define-syntax (rename 'define-syntax)))
    (let ((name (car code)) (args (cdr code)))
      (if (and (pair? xpr)
               (compare? (car xpr) %where)
               (not (null? xprs)))
        (let ((clauses (cdr xpr)))
          (let (
            (fenders
              (compress
                (map (lambda (clause)
                       (or (null? (cdr clause))
                           (and (not (compare? (cadr clause) %keyword))
                                (not (compare? (cadr clause) %injection)))))
                  clauses)
                clauses))
              ;(filter (lambda (clause)
              ;          (or (null? (cdr clause))
              ;              (and (not (compare? (cadr clause) %keyword))
              ;                   (not (compare? (cadr clause) %injection)))))
              ;       clauses))
            (keywords
              (compress
                (map (lambda (clause)
                       (and (not (null? (cdr clause)))
                            (compare? (cadr clause) %keyword)))
                     clauses)
                clauses))
              ;(filter (lambda (clause)
              ;          (and (not (null? (cdr clause)))
              ;               (compare? (cadr clause) %keyword)))
              ;        clauses))
            (injections
              (compress
                (map (lambda (clause)
                       (and (not (null? (cdr clause)))
                            (compare? (cadr clause) %injection)))
                     clauses)
                clauses))
              ;(filter
              ;  (lambda (clause)
              ;          (and (not (null? (cdr clause)))
              ;               (compare? (cadr clause) %injection)))
              ;        clauses))
            )
            (let (
              (keywords
                (if (null? keywords)
                  keywords
                  (map car keywords)))
              (injections
                (if (null? injections)
                  injections
                  (map car injections)))
              )
              `(,%define-syntax ,name
                 (,%macro-rules ,@injections ,keywords
                   ((_ ,@args) (where ,@fenders) ,@xprs))))))
        `(,%define-syntax ,name
           (,%macro-rules ()
             ((_ ,@args) ,xpr ,@xprs)))))))

#|[
Now follow the local versions of define-macro, macro-let and
macro-letrec. Since the syntax of both is identical, they are
implemented by means of a helper macro.
]|#

;; helper for macro-let and macro-letrec
(define-er-macro-transformer (macro-with form rename compare?)
  (let ((op (cadr form))
        (pat-tpl-pairs (caddr form))
        (xpr (cadddr form))
        (xprs (cddddr form))
        (%macro-rules (rename 'macro-rules)))
    (let ((pats (map car pat-tpl-pairs))
          (tpls (map cdr pat-tpl-pairs)))
      `(,op ,(map (lambda (pat tpl)
                    `(,(car pat)
                       (,%macro-rules ()
                         ((_ ,@(cdr pat)) ,@tpl))))
                  pats tpls)
                   ,xpr ,@xprs))))

;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
;;; -------------------------------------------------------------------------
;;; evaluates body ... in the context of parallel macros name ....
(define-er-macro-transformer (macro-let form rename compare?)
  (let ((pat-tpl-pairs (cadr form))
        (xpr (caddr form))
        (xprs (cdddr form));)
        (%macro-with (rename 'macro-with))
        (%let-syntax (rename 'let-syntax)))
    `(,%macro-with ,%let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))

;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
;;; ----------------------------------------------------------------------------
;;; evaluates body ... in the context of recursive macros name ....
(define-er-macro-transformer (macro-letrec form rename compare?)
  (let ((pat-tpl-pairs (cadr form))
        (xpr (caddr form))
        (xprs (cdddr form));)
        (%macro-with (rename 'macro-with))
        (%letrec-syntax (rename 'letrec-syntax)))
    `(,%macro-with ,%letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))

;;; (procedural-macros sym ..)
;;; --------------------------
;;; documentation procedure.
(define procedural-macros
  (let ((alst '(
    (macro-rules
      macro:
      (macro-rules literal ... (keyword ...) (pat (where fender ...) .. tpl) ....)
      "procedural version of syntax-rules"
      "with optional injected literals"
      "and quasiquoted templates")
    (define-macro
      macro:
      (define-macro (name . args) (where (x . xs) ...) .. xpr ....)
      "a version of macro-rules with only one rule"
      "xs is either a list of predicates, thus providing fenders"
      "or a singleton containing one of the symbols keyword or"
      "injection, providing keyword parameters or nonhygienic macros")
    (macro-let
      macro:
      (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
      "evaluates body ... in the context of parallel macros name ....")
    (macro-letrec
      macro:
      (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
      "evaluates body ... in the context of recursive macros name ....")
    (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 'procedural-macros
                  "not exported" sym)))))))
) ; procedural-macros