Procedural macros made easy with bindings (historical revision 32913)

You are looking at historical revision 32913 of this page. It may differ significantly from its current revision.

Procedural macros made easy with bindings

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?

This library provides the means for this to happen, in particular, two binding routines, bind and bind-case. The former is a Scheme implementation of Common Lisp's destructuring-bind, the latter a case variant of the former, similar to the match macro of the matchable library.

Based on those binding routines and implicit renaming, some macro-writing macros are defined, in paraticular, a hygienic procedural define-macro and a procedural version of syntax-rules, named macro-rules. The latter is almost as easy to use as syntax-rules, but much more powerfull. Here is its syntax

[syntax] (macro-rules sym ... (keyword ...) (pat (where fender ...) .. tpl) ....)

Note the special use of dots here and below: Three dots are ellipses, as usual, i.e. the pattern on the left is repeated zero or more times, two dots, zero or one time, 4 dots one ore several times.

This form can be used instead of syntax-rules in define-syntax, let-sytax and letrec-syntax, provided, you import it for-syntax. sym ... denote the injected symbols to break hygiene (if there is none, the constructed macro is hygienic). keyword ... and pat .... symbols are as in syntax-rules, fender ... are expressions on pattern variables which must pass for the pattern to match, and tpl .... are usually quasiquoted expressions.

And here is the syntax of define-macro

[syntax] (define-macro (name . args) (where fender ...) .. xpr ....))

Note, that only this hygienic form survived in this version 4.0 of the bindings library. To handle injected symbols or keywords use macro-rules. And note also, that you need to import-for-syntax bind in compiled code.

The bind macro is patterned after Paul Graham's dbind, cf. his classic "On Lisp", p. 232. Here is a Chicken version for lists:

(define-syntax dbind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (letrec (
        (mappend
          (lambda (fn lists)
            (apply append (map fn lists))))
        (destruc
          (lambda (pat seq)
            (let loop ((pat pat) (seq seq) (n 0))
              (if (pair? pat)
                (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
                  (if (symbol? p)
                    (cons `(,p (list-ref ,seq ,n)) recu)
                    (let ((g (gensym)))
                      (cons (cons `(,g (list-ref ,seq ,n))
                                  (loop p g 0))
                            recu))))
                (if (null? pat)
                  '()
                  `((,pat (list-tail ,seq ,n))))))))
        (dbind-ex
          (lambda (binds body)
            (if (null? binds)
              `(begin ,@body)
              `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
                          binds)
                 ,(dbind-ex
                    (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                             binds)
                    body)))))
        )         
        (let ((pat (cadr form))
              (seq (caddr form))
              (body (cdddr form))
              (gseq 'seq))
          `(let ((,gseq ,seq))
             ,(dbind-ex (destruc pat gseq) body)))))))

This code works as follows: First, destruc traverses the pattern and groups each symbol with some list accessing code, using gensyms to step down the pattern while grouping the gensym bound object with all pairs depending on this gensym. So, for example,

  (destruc '(a (b . c) . d) 'seq)

will result in

  ((a (list-ref seq 0))
   ((#:g (list-ref seq 1)) (b (list-ref #:g 0)) (c (list-tail #:g 1)))
   (d (list-tail seq 2)))

This tree is then transformed via dbind-ex into a nested let

  (let ((a (list-ref seq 0))
        (#:g (list-ref seq 1))
        (d (list-tail seq 2)))
    (let ((b (list-ref #:g 0))
          (c (list-tail #:g 1)))
      body))

Note, that the destructuring procedures are local to this macro. This is necessary in Chicken for the macro to work, in particular in compiled code, unless you import them for-syntax. But since they are of no interest outside of the macro, local procedures are preferable.

Note further, that ir-macro-transformer does all the necessary renaming transparently behind the scene, even if the helpers where defined in another module. In particular, gseq needn't be a gensym.

And note, that Graham's code didn't check for seq's length, i.e. (dbind (a b) '(1 2 3) (list a b) would happily return '(1 2).

Graham's original code works on the sequence datatype, so vectors and strings are destructured as well. Sequences don't exist in Scheme, unless you import-for-syntax Felix' sequences egg. To make this module self-contained, I prefer to supply access-routines closed over a table, which provides sequence versions of list-ref and list-tail, the only sequence routines used by destruc above, as well as a sequence version of length, which is needed to do the length checks.

There are some features, which I would like to have and which are implemented as well. First wildcards, represented by the underscore symbol. It matches everything, but binds nothing. So it can appear multiple times in the same macro. Wildcard symbols are simply not collected in the destruc routine.

Second, non-symbol literals, which don't bind anything, of course, but match only themselves. This and the length checks are treated simply by pairing them as well with check-routines in destruc but separating the pairs with leading symbol from those with leading nil or literal in dbind-ex. The former are bound with lets as in Graham's code, the latter's cadrs being evaluated before the recursive call to dbind-ex.

The last feature missing is fenders, which is important in particular for bind-case and can easily be implemented with a where clause: A pattern matches successfully if only each pattern variable can be bound and the where clause is satisfied. If the where clause doesn't pass, the next pattern is tried in bind-case or a bind-exception is signalled in bind.

Bindings

Off course, automatic destructuring of expressions is not only of interest in macro writing. For example, the ML-family of programming languages is based on it. Therefore, this library provides a bunch of macros, all starting with the bind prefix, and all being derived from bind and related procedures. They all destructure arbitrary mixtures of (pseudo-) lists, vectors and strings, which match a pattern, and can be easily enhanced, to accept other sequence types as well, arrays, for example. Here, a pattern is a nested pseudolist of symbols.

The module basic-bindings

basic-bindings

[procedure] (basic-bindings sym ..)

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

bind

[syntax] (bind pat seq (where fender ...) .. xpr ....)

binds pattern variables of pat to subexpressions of seq and executes xpr .... in this context, provided all fenders return #t, if supplied.

bindable?

[syntax] (bindable? pat (where fender ...))

returns a unary predicate which checks, if its sequence argument matches the pattern argument, pat, of bindable? and passes all of its fenders (the syntax is slightly changed for consistency).

bind-case

[syntax] (bind-case seq (pat (where fender ...) .. xpr ....) ....)

Matches seq against a series of patterns and executes the body of the first matching pattern satisfying fenders (if given).

bind-define

[syntax] (bind-define pat seq)

defines pattern variables of pat with values matching subexpressions of seq in one go

bind-set!

[syntax] (bind-set! pat seq)

sets symbols of pat to corresponding subexpressions of seq

bind-exception

[procedure] (bind-exception loc msg . args)

generates a composite condition of type (exn bind) with location loc, message msg and arguments args.

bind-exception-handler

[procedure] (bind-exception-handler var)

exception-handler to be passed to the parameter current-exception-handler

signal-bind-exception

[procedure] (signal-bind-exception loc msg arg ...)

signals a bind-exception, can be used instead of error.

bind-table-show

[procedure] (bind-table-show)

prints the contents of the table

bind-table-add!

[procedure] (bind-table-add! type? len ref tail)

adds a custom new list of sequence operators to the top of the table (in previous versions of the library named seq-length-ref-tail!)

bind-seq-length

[procedure] (bind-seq-length seq)

returns the length of the generic sequence seq (previously named seq-length)

bind-seq-ref

[procedure] (bind-seq-ref seq n)

returns the nth item of the generic sequence seq (preveiously named seq-ref)

bind-seq-tail

[procedure] (bind-seq-tail seq n)

returns the tail of the generic sequence seq, starting at n (previously named seq-tail)

symbol-dispatcher

[procedure] (symbol-dispatcher alist)

creates a documentation procedure as used in all modules of this library.

list-of

[procedure] (list-of ok? ...)

returns a predicate which checks, if its list argument passes every predicate ok? ...

vector-of

[procedure] (vector-of ok? ...)

returns a predicate which checks, if its vector argument passes every predicate ok? ...

The module macro-bindings

macro-bindings

[procedure] (macro-bindings sym ..)

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

macro-rules

[syntax] (macro-rules sym ... (keyword ...) (pat (where fender ...) .. tpl) ....)

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 a corresponding literal in the macro-code.

macro-rules must be imported for-syntax if used in the preprocessing phase of a macro evaluation. The same applies to bind and friends.

(use bindings)
(import-for-syntax (only bindings bind macro-rules with-gensyms once-only))

Examples


(use bindings)
(import-for-syntax
  (only bindings bind macro-rules with-gensyms once-only list-of bindable?))

(let ((stack #f) (push! #f) (pop! #f))
  (bind-set! (stack (push! pop!))
    (list
      '()
      (vector
        (lambda (xpr) (set! stack (cons xpr stack)))
        (lambda () (set! stack (cdr stack))))))
  (push! 1)
  (push! 0)
  stack)
; -> '(0 1)

(begin
  (bind-define (top push! pop!)
    (let ((lst '()))
      (vector
        (lambda () (car lst))
        (lambda (xpr) (set! lst (cons xpr lst)))
        (lambda () (set! lst (cdr lst))))))
  (push! 0)
  (push! 1)
  (pop!)
  (top))
; -> 0

(bind a 1 a)
; -> 1

(bind (x y z w) '(1 2 3 4) (list x y z w))
; -> '(1 2 3 4)

(bind (x . y) '#(1 2 3 4) (list x y))
; -> '(1 #(2 3 4))

(bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
  (list x y z u v w))
; -> '(1 2 #\f #\o "o" 4)

(bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons 3 4)) 5 6)
  (list x y z u v w))
; -> '(1 2 3 4 5 #(6))

((bind-lambda (a (b . C) . d)
   (list a b C d))
 '(1 #(20 30 40) 2 3))
; -> '(1 20 #(30 40) (2 3))

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

(bind* loop (x (a . b) y) '(5 #(1) 0)
  (if (zero? x)
    (list x a b y)
    (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
; -> '(0 1 (1 1 1 1 1 . #()) 5)

(bind* loop (x y) '(5 0)
  (if (zero? x)
    (vector x y)
    (loop (vector (- x 1) (+ y 1)))))
; -> '#(0 5)

(bind-let (((x y (z . w)) '(1 2 #(3 4 5))))
  (list x y z w))
; -> '(1 2 3 #(4 5))

(bind-let (
  (((x y) z) '(#(1 2) 3))
  (u (+ 2 2))
  ((v w) '#(5 6))
  )
  (list x y z u v w))
; -> '(1 2 3 4 5 6)

(bind-let loop (((a b) '(5 0)))
  (if (zero? a)
    (list a b)
    (loop (list (list (- a 1) (+ b 1))))))
; -> '(0 5)

(bind-let loop (
  ((x . y) '(1 2 3))
  ((z) '#(10))
  )
  (if (zero? z)
    (list x y z)
    (loop (list (cons (+ x 1) (map add1 y)) (list (- z 1))))))
; -> '(11 (12 13) 0)

(bind-let* (
  (((x y) z) '(#(1 2) 3))
  (u (+ 1 2 x))
  ((v w) (list (+ z 2) 6))
  )
  (list x y z u v w))
; -> '(1 2 3 4 5 6)

(bindrec ((o?) e?)
  (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
  (list (o? 95) (e? 95)))
; -> '(#t #f)

(bind-letrec (
  ((o? (e?))
   (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
         (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
  )
  (list (o? 95) (e? 95)))
; -> '(#t #f)

((bindable? ()) '())
; -> #t

((bindable? (a (b C) . d)) '(1 (2 3) . 4))
; -> #t

((bindable? (a (b C) . d)) '(1 #(2 3) 4 5))
; -> #t

((bindable? (a (b . C) . d)) '(1 (2 3) 4))
; -> #t

((bindable? (a (b . C) . d)) '#(1 2 3 4 5))
; -> #f

((bindable? (a (b C) d)) '(1 (2 3) 4 5))
; -> #f

((bindable? (a b) (even? a)) '#(1 2))
; -> #f 

(bind-case '#(1 2)
  (() '())
  ((a) (list a))
  ((a b) (list a b))
  ((a b C) (list a b C)))
; -> '(1 2))

(letrec (
  (my-map
    (lambda (fn lst)
      (bind-case lst
        (() '())
        ((x . xs) (cons (fn x) (my-map fn xs))))))
  )
  (my-map add1 '(1 2 3)))
; -> '(2 3 4)

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

((bind-case-lambda
   ((e . f) (where (zero? e)) f)
   ((e . f) (list e f)))
 '#(0 2 3 4 5))
;-> '#(2 3 4 5))

((bind-case-lambda
   ((a (b . C) . d) (list a b C d))
   ((e . f) (list e f)))
 '(1 #(2 3 4) 5 6))
; -> '(1 2 #(3 4) (5 6))

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

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

;;adding arrays to generic sequence table
(bind-table-add!  array?
                  array-length
                  (lambda (seq k)
                    (array-item k seq))
                  (lambda (seq k)
                    (array-drop k seq)))

(bind (x y z) (array 1 2 3) (list x y z))
;-> '(1 2 3)

(bind (x (y z)) (vector 0 (array 1 2)) (list x y z))
;-> '(0 1 2)

(bind (x (y . z)) (vector 0 (array 1 2 3 4)) (list x y z))
;-> '(0 1 @(2 3 4))

;; 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-macro (alambda args xpr . xprs)
  (inject self)
  `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
     ,self))

;; effective membership testing
(define-macro (in? what equ? . choices)
  (let ((insym 'in))
    `(let ((,insym ,what))
       (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
                  choices)))))

(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 ((temp test))
       `(if ,temp (,xpr ,temp))))
    ((_ (test => xpr) . clauses)
     (let ((temp test))
       `(if ,temp
          (,xpr ,temp)
          (my-cond ,@clauses))))
    ((_ (test)) `(,void))
    ((_ (test) . clauses)
     (let ((temp test))
       `(if ,temp
          ,temp
          (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 var-val-pairs . body)
              (where ((list-of (bindable? (var val)))
                      var-val-pairs))
  (let ((vars (map car var-val-pairs))
        (vals (map cadr var-val-pairs))
        (aux (map (lambda (x) (gensym)) var-val-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)
         ,@body))))

(my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
            (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
           (list (o? 95) (e? 95)))

;; local macros
(letrec-syntax (
     (sec (macro-rules ()
               ((_ lst) `(car (res ,lst)))))
     (res (macro-rules ()
             ((_ lst) `(cdr ,lst))))
     )
     (sec '(1 2 3)))
;-> 2

(macro-letrec (
     ((sec lst) `(car (res ,lst)))
     ((res lst) `(cdr ,lst))
     )
     (sec '(1 2 3)))
;-> 2

(macro-let (
     ((fir lst) (where (list? lst)) `(car ,lst))
     ((res lst) (where (list? lst)) `(cdr ,lst))
     )
     (fir (res '(1 2 3))))
;-> 2

;; non-symbolic literals
(define-syntax foo
  (macro-rules ()
    ((_ "foo" x) x)
    ((_ #f x) `(list 'false))
    ((_ #f x) 'false)
    ((_ a b) (where (string? a)) `(list ,a ,b))
    ((_ a b) (where (odd? a)) `(list ,a ,b))
    ((_ a b) a)))
(foo "foo" 1)
; -> 1
(foo "bar" 2)
; -> '("bar" 2)
(foo #f 'blabla)
; -> '(false)
(foo 1 2)
; -> '(1 2)
(foo 2 3)
; -> 2

Copyright (c) 2011-2015, 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

4.0: code completely rewritten,simplified and reorganized, some small syntax changes
3.5.2: code reorganized again to fix compile problems
3.5.1: code reorganized
3.5: let-macro and letrec-macro added, list-of? replaced by list-of to accept zero to many predicates
3.4: where and key clauses now work together in macro-rules, moreover, macro-rules can be used in define-macro, so it needn't be imported for-syntax
3.3: bindings library split in two; fixed a compile-time bug, thanks to John Foerch and Moritz Heidkamp
3.2: wild-card processing added
3.1: support for once formal parameters, rename-prefix clause moved to parameter, let-macro and letrec-macro changed to er-macro and renamed
3.0.1: bugfix in define-er-macro, bind/cc added, three macros moved to macro-helpers
3.0: library now includes low-level-macros
2.5: all macros are low-level. Module depends on low-level-macros
2.4.1: documentation procedure beautified
2.4: generic functions rewritten, records removed from tests
2.3.4: internal generic-pair? added again bugfixed
2.3.3: exception-handler added, internal generic-pair? removed
2.3.2: bind-case improved, format replaced by print
2.3: code partially rewritten, syntax of bindable? changed, matching records outsourced to the tests
2.2: renamed bind? to bindable?, bind/cc moved to list-bindings
2.1: generics (and hence bind and friends) now accept records, bind/cc added
2.0: bind-matches? and bind-loop changed to bindable? and bind*, where clauses and generic functions added, syms->vars removed
1.0: all binding macros can now destructure arbitrary nested sequences, i.e mixtures of lists, pseudo-lists, vectors and strings; dependency on contracts removed.
0.1: initial import