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

Low-level macros made easy with bindings

This module contains some macros to make the use of low-level macros easier. It replaces the now obsolete modules er-macros and ir-macros as well as low-level-macros.

Recall that low-level macros are implemented as transformer routines, which are three-parameter procedures enclosed in er-macro-transformer or ir-macro-transformer respectively

(er-macro-transformer
  (lambda (form rename compare?) ...))
(ir-macro-transformer
  (lambda (form inject compare?) ...))

The programmer's job is to destructure the macro-code, form, and to do the renaming of all symbols which should appear in the macro-expansion by hand in the explicit-renaming case or to inject those symbols, which should not be renamed in the implicit-renaming case. In any case, symbols which are not renamed are unhygienic. The third parameter allows to handle additional keywords.

Each of these transformer arguments does a special job, each of which is tedious and error-prone. In this module, we'll automate each of these jobs.

Let's start with destructuring the macro-code. It can be done by a local macro, dbind, which in turn uses procedures destruc, dbind-ex, dbind-lit and dbind-len, which must be imported for-syntax and hence should appear in a helper module, macro-helpers. The implementation of dbind follows Graham's 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))))
                (let ((tail `(list-tail ,seq ,n)))
                  (if (null? pat)
                    '()
                    `((,pat ,tail))))))))
        (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)))))))

Its local procedures will be put in the helper module which must be imported for-syntax. The other destructuring procedures in the helper module are needed for checking the length of sequences and for coping with non-symbol literals.

Programming interface

Documentation

This documentation uses special ellipses, .. or ...., to repeat the pattern to the left at most once or at least once respectively

The module macro-helpers

macro-helpers

[procedure] (macro-helpers sym ..)

shows which symbols are exported, if called with no argument, or sym's documentation.

symbol-dispatcher

[procedure] (symbol-dispatcher alist)

creates a documentation procedure as used by macro-helpers and low-level-macros.

bind-exception

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

generates a composite condition of type (exn bind) with location loc, message msg and arguments args. Imported and reexported by low-level-macros.

add-prefix

[procedure] (add-prefix pref id)

adds a prefix to a symbol.

prefixed-with?

[procedure] (prefixed-with? pre)

returns a predicate, which checks, if pre is a prefix of its argument.

strip-prefix

[procedure] (strip-prefix pre id)

strips the prefix pre from the identifier id.

strip-suffix

[procedure] (strip-suffix suf id)

strips the suffix suf from the identifier id.

extract

[procedure] (extract ok? tree)

returns a flat list of all the symbols in a tree which pass the ok? test.

remove-duplicates

[procedure] (remove-duplicates lst)

returns a sublist of lst with dups removed.

adjoin

[procedure] (adjoin obj lst)

conses obj to lst provided it isn't already there.

memp

[procedure] (memp ok? lst)

returns the tail of lst, whose car passes ok?, or #f otherwise.

assp

[procedure] (assp ok? tbl)

returns the table item whose car passes ok?

replace*

[procedure] (replace* what? by tree)

substitutes each old with (what? old) by (by old) in a tree.

map*

[procedure] (map* fn . trees)

tree-version of map. Returns a tree.

flatten

[procedure] (flatten tree)

returns a flat list with all the items of tree.

flatten-map*

[procedure] (flatten-map* fn . trees)

combination of flatten and map*. Returns a list.

filter

[procedure] (filter ok? lst)

returns two sublists of lst where each item passes ok? or not ok? respectively.

mappend

[procedure] (mappend fn lists)

combination of map and append, i.e. mapcan in CL.

plist?

[procedure] (plist? xpr)

is xpr a pseudolist? Allways #t.

pnull?

[procedure] (pnull? xpr)

is xpr a null? pseudolist? For example (pnull? 1) is true.

plength

[procedure] (plength pl)

returns the length of a pseudolist. For example (plength 1) is 0. Imported for-syntax and reexported by low-level-macros.

plist-ref

[procedure] (plist-ref pl k)

returns the kth item of a pseudolist. Imported for-syntax and reexported by low-level-macros.

plist-tail

[procedure] (plist-tail pl k)

returns the tail, starting from k, of a pseudolist. Imported for-syntax and reexported by low-level-macros.

seq-length

[procedure] (seq-length seq)

returns the length of the generic sequence seq, presently a string, vector or (pseudo-)list.

seq-ref

[procedure] (seq-ref seq n)

returns the nth item of the generic sequence seq, presently a string, vector or (pseudo-)list.

seq-tail

[procedure] (seq-tail seq n)

returns the tail of the generic sequence seq, presently a string, vector or (pseudo-)list, starting at n.

seq-length-ref-tail!

[procedure] (seq-length-ref-tail! type? type-length type-ref type-tail)

updates the local tables of seq-length, seq-ref and seq-tail in one go by adding appropriate pairs to its front.

vector-tail

[procedure] (vector-tail vec k)

returns the subvector of vec starting with index k.

list-of?

[procedure] (list-of ok?)

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

atom?

[procedure] (atom? xpr)

same as (not (pair? xpr)).

list-destruc

[procedure] (list-destruc pat seq)

helper, which does most of the work to destructure seq according to the pattern pat, a nested pseudolist of symbols and non-symbol literals. Returns three lists, to be used by dbind-ex, dbind-lit and dbind-len respectively.

seq-destruc

[procedure] (seq-destruc pat seq)

same as list-destruc, but destructures generic sequences. Used in the bindings module.

dbind-ex

[procedure] (dbind-ex symbols body)

where body is a list starting with a fender expression and symbols is the first returned value of list- or seq-destruc. Generates a nested let expression.

dbind-lit

[procedure] (dbind-lit literals)

where literals is the second returned value of list- or seq-destruc. Generates code which checks if literals match.

dbind-len

[procedure] (dbind-len length-checks)

where length-checks is the third returned value of list- or seq-destruc. Generates code which checks if pat and seq are matchable at all.

dbind-def

[procedure] (dbind-def op symbols)

where op is either 'set! or 'define and symbols is the first returned value of list- or seq-destruc. Returns code for bind-define or bind-set! in the bindings module.

once-only

[syntax] (once-only (x ...) . body)

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-gensyms

[syntax] (with-gensyms (x ...) . body)

to be used in a macro body. Generates a list of gensyms x ... with-gensyms must be imported for-syntax.

define-syntax-rule

[syntax] (define-syntax-rule (name . args) (keywords x ...) .. tpl)

the only high-level macro. To be used instead of syntax-rules in case there is only one rule and no additional keywords.

The module bindings

The bindings module is a light-weight alternative to the matchable egg together with some enhancements, in particular the bind macro, which is Common Lisp's destructuring-bind.

Contrary to matchable, there is no attempt to implement ellipses, Scheme's dotted lists must do. Instead of the match macro you should use bind-case. And contrary to matchable, all binding macros can destructure arbitrary nested sequences, i.e. mixtures of lists, pseudo-lists, vectors and strings. Other types of sequences can be added by clients.

bindings

[procedure] (bindings sym ..)

Documentation procedure. Called without argument it returns the list of exported symbols, with one of those symbols as argument it returns its documentation.

bind

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

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

bindable?

[syntax] (bindable? pat . fenders)

returns a unary predicate which checks, if its sequence argument matches the pattern argument, pat, of bindable? and passes all of its fenders.

bind-case

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

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

bind-case-lambda

[syntax] (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)

Combination of bind-case and lambda with one pattern argument

bind-case-lambda*

[syntax] (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)

Combination of bind-case and lambda with multiple pattern arguments

bind-lambda

[syntax] (bind-lambda pat (where . fenders) .. xpr ....)

combination of lambda and bind, one pattern argument

bind-lambda*

[syntax] (bind-lambda* pat (where . fenders) .. xpr ....)

combination of lambda and bind, multiple pattern arguments

bind-let

[syntax] (bind-let loop .. ((pat seq) ...) xpr ....)

like let, named and unnamed, but binds patterns to sequence templates. In the named case loop is bound to a one-parameter-procedure accessible in the body xpr ....

bind-let*

[syntax] (bind-let* ((pat seq) ...) xpr ....)

like let*, but binds patterns to sequence templates

bind-letrec

[syntax] (bind-letrec ((pat seq) ...) xpr ....)

like letrec, but binds patterns to sequence templates

bind*

[syntax] (bind* loop pat seq xpr ....)

named version of bind. loop is bound to a one-parameter procedure, which can be used in the body xpr ....

bindrec

[syntax] (bindrec pat seq xpr ....)

bind pattern variables of pat to subsequences of seq recursively

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

As implemented, the binding macros can handle arbitrary nested combinations of (pseudo-)lists, vectors and strings. But updating the table additional sequence types can be handled without touching the macros' code.

macro-rules

[syntax] (macro-rules sym ... (keyword ...) (pat (where . fenders) .. 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.

define-macro

[syntax] (define-macro (name . args) xpr ....))
[syntax] (define-macro (name . args) (inject sym ...) xpr ....))
[syntax] (define-macro (name . args) (inject sym ...) (keywords key ...) xpr ....))
[syntax] (define-macro (name . args) (keywords key ...) (inject sym ...) xpr ....))

generates an implicit-renaming macro, name. Keywords and injected symbols are extracted from the macro body and transformed into appropriate subexpressions of the macro-transformer.

let-macro

[syntax] (let-macro ((code . body) ....) xpr ....)

where (code . body) .... are as in define-macro.

This is a local version of define-macro, allowing a list of (code . body) lists to be processed in xpr .... in parallel.

letrec-macro

[syntax] (letre-macro ((code0 . body) ....) xpr ....)

where (code0 . body) .... are as in define-macro.

This is a local version of define-macro, allowing a list of (code . body) lists to be processed in xpr .... recursively.

define-er-macro

[syntax] (define-er-macro (name . args) (rename-prefix pre) . body)

where body can start with an optional (keywords key ...) clause.

Defines an explicit-renaming macro by renaming every symbol in the body which starts with prefix pre.

Requirements

None

Usage

(require-library bindings)
(import-for-syntax (only bindings macro-rules))
(import bindings bindings macro-helpers)

Examples


(use bindings tuples)

(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)

(let ((two '(1 2)))
  (bind-matches? two ()))
; -> #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 new types to generics 
(seq-length-ref-tail!  tuple?  tuple-length tuple-ref tuple-from-upto)
(bind (x y z) (tuple 1 2 3) (list x y z)) ;-> '(1 2 3)
(bind (x (y z)) (vector 0 (tuple 1 2)) (list x y z)) ;-> '(0 1 2)

;; 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)))))

;; two versions of a verbose if
(define-er-macro (verbose-if test (then . xprs) (else . yprs))
  (rename-prefix %)
  (keywords then else)
  `(,%if ,test
     (,%begin ,@xprs)
     (,%begin ,@yprs)))

(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)))))

;; low-level 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)) test)
    ((_ (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)))))

;; low-level version of letrec
(define-macro (my-letrec pairs . body)
  (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)
         ,@body))))

;; 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

Last update

Jan 31, 2014

Author

Juergen Lorenz

License

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