source: project/wiki/eggref/5/procedural-macros @ 38711

[[tags: egg]]
[[toc:]]

== Procedural macros made easy

The Scheme standard, R5RS, only provides declarative macros based on
syntax-rules. They are easy to use, but rather limited. For example, you
can only create hygienic macros, you have no control over the expansion
process, in particular, you can't use local procedures to be evaluated at
compile time. To overcome this limitations, R6RS offers syntax-case
macros, but that's a mouthfull ...

Fortunately, Chicken offers two versions of procedural macros, explicit
and implicit renaming macros. They offer full flexibility without any
limitations but are tedious to use.

First, you must care to avoid variable capture with renaming if you
want hygienic macros, or you must decide which variables should be
captured on purpose. Implicit renaming here helps a lot: You simply
inject names which you want to be captured, the others are renamed
automatically by the runtime system.

Second, you must do the destructuring of the macro code by hand.
Wouldn't it be nice, if this could be done automatically behind the
scene as well?  Well, two macros of the bindings egg, bind and bind-case,
will help here.

This library provides the means for this to happen. In particular,
you'll find variants of good old define-macro. And macro-rules are
implemented, which looks much like syntax-rules but doesn't have its
limitations.


=== Module procedural-macros

==== define-er-macro

<macro>(define-er-macro (name . args) (where . fenders) prefix xpr . xprs)</macro>
<macro>(define-er-macro (name . args) prefix xpr . xprs)</macro>
<macro>(define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)</macro>
<macro>(define-er-macro name (pat prefix xpr . xprs) . others)</macro>

where fenders are of the form (key? sym) most of the time, to check for keywords.
A version of good old define-macro, where symbols prefixed with prefix are
automatically renamed.

==== define-ir-macro

<macro>(define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)</macro>
<macro>(define-ir-macro (name . args) prefix xpr . xprs)</macro>
<macro>(define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)</macro>
<macro>(define-ir-macro name (pat prefix xpr . xprs) . others)</macro>

where fenders are of the form (key? sym) most of the time, to check for keywords.
A version of good old define-macro, where symbols prefixed with prefix
are automatically injected.

==== define-macro

<macro>(define-macro (name . args) body )</macro>

where body is either
* (with-explicit-renaming (c? %x ...) xpr ....)
* (with-implicit-renaming (c? %x ...) xpr ....)
or simply
* xpr ....

defines an explicit- or implicit-renaming macro with body xpr ....
c? is a compare-routine to handle keys and %x ... are renamed or
injected symbols to be used in the body.

The last form is implicit-renaming without injections and keys.

==== macro-rules

<macro>(macro-rules sym ... (key ...) (pat tpl) ....)</macro>

like syntax-rules, but the templates are usually quasiquote-expressions.
Moreover, the symbols sym ... are injected, if there are any.

Note, that non-symbol literals are accepted in each pat and considered a
match if they are equal to the corresponding expression in the
macro-code. The keys are transformed to keyword literals behind the
scene.

macro-rules must be imported for syntax if used in the preprocessing
phase of a macro evaluation.

==== macro-let

<macro>(macro-let (((name . args) xpr ...) ...) xpr ....)</macro>

evaluates xpr .... in the context of parallel hygienic macros name ...

==== macro-letrec

<macro>(macro-letrec (((name . args) xpr ...) ...) xpr ....)</macro>

evaluates xpr .... in the context of recursive hygienic macros name ...

==== once-only

<macro>(once-only (x ...)  body ....)</macro>

to be used in a macro-body to avoid side-effects.
The arguments x ... are only evaluated once.

once-only must be imported for-syntax.

==== with-renamed-symbols

<macro>(with-renamed-symbols (renamer %x ....) xpr ....)</macro>

binds a series of prefixed names, %x ....
to the images of the original names, x ...., under renamer
and evaluates xpr .... in this context.

The prefix is arbitrary, but must be only one letter.
The macro must be imported for syntax.

==== with-gensyms

<macro>(with-gensyms (x ...) xpr ....)</macro>

to be used in a macro body and hence to be imported for-syntax.
Generates a list of gensyms x ... which can be used in xpr .....

The macro must be imported for syntax.

==== procedural-macros

<procedure>(procedural-macros sym ..)</procedure>

documentation procedure. Shows the exported symbols and the syntax of
such an exported symbol, respectively.

=== Requirements

bindings

=== Usage

<enscript highlight=scheme>

(import procedural-macros)

(import-for-syntax
 (only procedural-macros macro-rules once-only
       with-renamed-symbols with-gensyms)

</enscript>

=== Examples

<enscript highlight=scheme>

(import procedural-macros)
(import-for-syntax
  (only checks <<)
  (only bindings bind bind-case)
  (only procedural-macros macro-rules with-renamed-symbols once-only))

;; NUMERIC AND VERBOSE IF AS ER-MACRO

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

(define-er-macro er-vif
  ((_ test (then . xprs) (else . yprs))
   (where (key? then) (key? else))
   %
   `(,%if ,test (,%begin ,@xprs) (,%begin ,@yprs))))

;; COND AND CASE AS ER- OR IR-MACRO

(define-er-macro er-cond
  ((_ (else xpr . xprs))
   (where (key? else))
   %
   `(,%begin ,xpr ,@xprs))
  ((_ (test => xpr))
   (where (key? =>))
   %
   `(,%let ((,%tmp ,test))
      (,%if ,%tmp (,xpr ,%tmp))))
  ((_ (test => xpr) . clauses)
   (where (key? =>))
   %
   `(,%let ((,%tmp ,test))
      (,%if ,%tmp
        (,xpr ,%tmp)
        (,%er-cond ,@clauses))))
  ((_ (test))
   %
   ;`(if #f #f))
   test)
  ((_ (test) . clauses)
   %
   `(,%let ((,%tmp ,test))
      (,%if ,%tmp
        ,%tmp
        (,%er-cond ,@clauses))))
  ((_ (test xpr . xprs))
   %
   `(,%if ,test (,%begin ,xpr ,@xprs)))
  ((_ (test xpr . xprs) . clauses)
   %
   `(,%if ,test
      (,%begin ,xpr ,@xprs)
      (,%er-cond ,@clauses)))
  )

(define-ir-macro ir-case* ; helper
  ((_ key (else result . results))
   (where (key? else))
   %
   `(begin ,result ,@results))
  ((_ key (keys result . results))
   %
   `(if (memv ,key ',keys)
      (begin ,result ,@results)))
  ((_ key (keys result . results) clause . clauses)
   %
   `(if (memv ,key ',keys)
      (begin ,result ,@results)
      (ir-case* ,key ,clause ,@clauses)))
  )

(define-ir-macro (ir-case key clause . clauses)
  %
  ;`(let ((tmp ,key)) ; ok
  ;   (ir-case* tmp ,clause ,@clauses)))
  (let ((tmp key)) ; ok
    `(ir-case* ,tmp ,clause ,@clauses)))

;; ALAMBDA AS ER- AND IR-MACRO

(define-ir-macro (ir-alambda args xpr . xprs)
  %
  `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
     ,%self))

(define-er-macro (er-alambda args xpr . xprs)
  %
  `(,%letrec ((self (,%lambda ,args ,xpr ,@xprs)))
     self))

;; TWO ANAPHORIC MACROS
(define-syntax aif
  (macro-rules it ()
    ((_ test consequent)
     `(let ((,it ,test))
        (if ,it ,consequent)))
    ((_ test consequent alternative)
     `(let ((,it ,test))
        (if ,it ,consequent ,alternative)))))

(define-syntax alambda
  (macro-rules self ()
    ((_ args xpr . xprs)
     `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
        ,self))))

;; VERBOSE IF
(define-er-macro % (vvif test (then . xprs) (else . yprs))
  (lambda (compare?)
    (if (and (compare? then %then) (compare? else %else))
      `(,%if ,test (,%begin ,@xprs) (,%begin ,@yprs))
      `(,%error 'vvif "wrong keys" then else))))

;; EFFICIENT MEMBERSHIP TESTING
(define-macro (in what equ? . choices)
  (let ((insym 'in))
    `(let ((,insym ,what))
       (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
                  choices)))))

;; FOR WITH ONCE-ONLY
(define-macro (for (var start end) xpr . xprs)
  (once-only (start end)
    `(do ((,var ,start (add1 ,var)))
       ((= ,var ,end))
       ,xpr ,@xprs)))

;; VERBOSE IF
(define-syntax vif
  (macro-rules (then else)
    ((_ test (then xpr . xprs))
     `(if ,test
        (begin ,xpr ,@xprs)))
    ((_ test (else xpr . xprs))
     `(if ,(not test)
        (begin ,xpr ,@xprs)))
    ((_ test (then xpr . xprs) (else ypr . yprs))
     `(if ,test
        (begin ,xpr ,@xprs)
        (begin ,ypr ,@yprs)))))

;; PROCEDURAL VERSION OF COND
(define-syntax my-cond
  (macro-rules (else =>)
    ((_ (else xpr . xprs))
     `(begin ,xpr ,@xprs))
    ((_ (test => xpr))
     `(let ((tmp ,test))
        (if tmp (,xpr tmp))))
    ((_ (test => xpr) . clauses)
     `(let ((tmp ,test))
        (if tmp
          (,xpr tmp)
          (my-cond ,@clauses))))
    ((_ (test))
     ;`(if #f #f))
     test)
    ((_ (test) . clauses)
     `(let ((tmp ,test))
        (if tmp
          tmp
          (my-cond ,@clauses))))
    ((_ (test xpr . xprs))
     `(if ,test (begin ,xpr ,@xprs)))
    ((_ (test xpr . xprs) . clauses)
     `(if ,test
        (begin ,xpr ,@xprs)
        (my-cond ,@clauses)))
    ))

;; PROCEDURAL VERSION OF LETREC
(define-macro (my-letrec pairs xpr . xprs)
  (<< pairs (list-of? pair?))
  (let ((vars (map car pairs))
        (vals (map cadr pairs))
        (aux (map (lambda (x) (gensym)) pairs)))
    `(let ,(map (lambda (var) `(,var #f)) vars)
       (let ,(map (lambda (a v) `(,a ,v)) aux vals)
         ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
         ,xpr ,@xprs))))

;; NON-SYMBOLIC LITERALS
(define-syntax foo
  (macro-rules ()
    ((_ "foo" x) x)
    ((_ #f x) `(list 'false))
    ((_ #f x) 'false)
    ((_ a b) (<< a string?) `(list ,a ,b))
    ((_ a b) (<< a odd?) `(list ,a ,b))
    ((_ a b) a)))

;; LOCAL MACROS
(macro-let (
  ((first lst)
   `(car (<< ,lst list?)))
  ((rest lst)
   `(cdr (<< ,lst list?)))
  )
  (first (rest '(1 2 3))))

(macro-letrec (
  ((second lst) `(car (rest ,lst)))
  ((rest lst) `(cdr ,lst))
  )
  (second '(1 2 3)))

</enscript>

== Last update

May 28, 2020

== Author

[[/users/juergen-lorenz|Juergen Lorenz]]

== License

 Copyright (c) 2015-2020, Juergen Lorenz
 All rights reserved.

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

== Version History

; 3.0.1 : some code simplified
; 3.0 : define-er-macro and define-ir-macro added
; 2.1 : bug in macro-let and macro-letrec fixed
; 2.0 : simplyfied and streamlined rewrite. Only one module remains.
; 1.1 : fixed some bugs reported by Diego. I thank him.
; 1.0.1 : port from chicken-4 procedural- and basic-macros