Title

Syntactic computations with computation-rules

Author

Andre van Tonder

Status

This SRFI is currently in ``withdrawn'' status. To see an explanation of each status that a SRFI can hold, see here. It will remain in draft status until 2004/05/16, or as amended. To provide input on this SRFI, please mail to <srfi minus 53 at srfi dot schemers dot org>. See instructions here to subscribe to the list. You can access previous messages via the archive of the mailing list.

Abstract

This SRFI provides a portable framework for writing complex high-level macros that perform nontrivial computations during expansion.

Rationale

Since R5RS [1], Schemers have had at their disposal an elegant, standardized way of writing high-level hygienic macros using syntax-rules.

The syntax-rules system is designed for ease of use in writing simple macros "by example". As for more complex macros, it was shown by Hilsdale and Friedman [2] that syntax-rules can express macro transformations that perform arbitrary computations over expression shapes. Their technique involves writing syntax transformations in continuation-passing style.

To the average programmer, nontrivial continuation-style macros are hard to write, read and maintain. Because of this, syntax-rules is not generally used for nontrivial applications.

In this SRFI we provide a portable framework for writing macros that perform nontrivial syntactic computations in a more direct style, liberating the programmer from dealing with the administrative details involved in continuation-passing style. The framework is built using syntax-rules and still uses continuation-passing under the hood, but this fact is hidden from the programmer. The interface is monadic and has aspects in common with syntax-case.

Examples

Here we list only a few simple examples to point out a few features of this SRFI. A more useful and complex example (implementing records with labeled fields) will be sketched after the specification below.

Let's define a simple computation to append two s-expressions:

  (define-syntax-computation syntax-append
    (computation-rules ()
      ((syntax-append () y)      (syntax-return y))
      ((syntax-append (h . t) y) (syntax-do (rest <- (syntax-append t y))
                                            (syntax-return (h . rest))))))
This is very similar to the way one would define this function in ordinary Scheme. On the right hand side of each rule, we provide a syntax computation. In the first case, we simply return the second argument. In the second case, we use syntax-do (which is analogous to the Scheme let*) to perform an intermediate computation (syntax-append t y) and bind the resulting syntax to rest, which is then inserted in the final result. We can now run the computation as follows:
  (syntax-run (syntax-append (list 1 2) (3 4 5)))  ;==> (1 2 3 4 5)
We can have more than one intermediate computation, for example:
  (define-syntax-computation syntax-map
    (computation-rules ()
      ((syntax-map f ())      (syntax-return ()))
      ((syntax-map f (h . t)) (syntax-do (x <- (f h))
                                         (y <- (syntax-map f t))
                                         (syntax-return (x . y))))))

  (syntax-inspect (syntax-map syntax-atom? (1 x (d e))))  ;==> (#t #t #f)
The form syntax-inspect here just returns the expanded s-expression quoted. The computation syntax-atom? is provided as part of the SRFI.

For defining local bindings, we may use let-syntax-computation and letrec-syntax-computation. For example:

  (define-syntax-computation syntax-reverse
    (computation-rules ()
      ((syntax-reverse s)                 
       (letrec-syntax-computation
           ((syntax-reverse*
             (computation-rules ()
               ((syntax-reverse* () accum) (syntax-return accum))
               ((syntax-reverse* (h . t) accum)
                (syntax-reverse* t (h . accum))))))
         (syntax-reverse* s ())))))

  (syntax-inspect (syntax-map syntax-reverse ((1 2) (3 4))))  ;==>  ((2 1) (4 3))
We also have the ability to declare anonymous computations, for example:
  (syntax-inspect ((computation-rules ()
                     ((_ x) (syntax-return (x x))))
                   1))
     ;==> (1 1)

  (syntax-inspect (syntax-map 
                     (computation-rules ()
                       ((_ x) (syntax-return (x x))))
                     (1 2 3)))

      ;==> ((1 1) (2 2) (3 3))
In addition, we have forms for testing whether a piece of syntax is atomic, a symbol, as well as conditionals and forms for pattern matching. Here is an example of their use:
  (define-syntax-computation syntax-eq?
    (computation-rules ()
      ((syntax-eq? x y)
       (syntax-if (syntax-symbol? x)
                  (let-syntax-computation 
                      ((test (computation-rules (x)
                               ((test x)     (syntax-return #t))
                               ((test non-x) (syntax-return #f)))))
                    (test y))
                  (syntax-if (syntax-atom? x)   
                             (syntax-match* y
                               (x     (syntax-return #t))
                               (non-x (syntax-return #f)))
                             (syntax-return #f))))))

  (syntax-run (syntax-eq? x x))   ;==> #t
  (syntax-run (syntax-eq? x y))   ;==> #f
As part of the library, we provide some useful list primitives (such as syntax-foldl, as well as primitives for capturing and invoking continutations. For example,
  (define-syntax-computation all-true?
    (computation-rules ()
      ((all-true? ls)
       (syntax-let/cc break
         (syntax-foldl (computation-rules ()
                         ((_ #f seed) (syntax-invoke/c break (syntax-return #f)))
                         ((_ #t seed) (syntax-return #t)))
                       #t
                       ls)))))

  (syntax-run (all-true? (#t #f #t #t)))
Here syntax-foldl iterates over a list from left to right. Very much as in ordinary Scheme, we can break out of the loop by capturing the current syntactic continuation before beginning the iteration, and then invoking that continuation when we want to break out.

Organization of the interface

As shown by Moggi, Wadler and others [4, 5], the notion of a monad unifies diverse notions of computation. Syntactic computations are no exception, and we have therefore chosen to organize the core interface around a small set of monadic primitives, using notation similar to that of Haskell. These primitives are easy to use, have analogues in the popular syntax-case system [3], and require no knowledge of monads from the programmer.

The basic primitives are

    syntax-return
    syntax-do
    syntax-run
The first of these, syntax-return, simply makes a trivial computation out of a piece of syntax and is analogous to the syntax-case: syntax primitive [3]. The second, syntax-do, sequences a set of computations and is analogous to the syntax-case: with-syntax primitive. The third of these, syntax-run, is used to perform a syntactic computation, giving as a result a piece of syntax.

Here is a simple comparison for those familiar with syntax-case:

(define-syntax test                              (define-syntax-computation test
  (lambda (stx)                                     (computation-rules ()
    (syntax-case stx ()
      ((test var)                                     ((test var)
       (with-syntax                                    (syntax-do 
           ((body (syntax (cons var var))))              (body <- (syntax-return (cons var var)))                                                    
         (syntax                                         (syntax-return 
           (let ((var 1)) body)))))))                      (let ((var 1)) body))))))

(test x)    ;==> (1 . 1)                         (syntax-run (test x))  ;==> (1 . 1)
Specific to the syntax computation monad are the further primitives
    syntax-let/cc
    syntax-invoke/c
    syntax-root/c 
used for capturing the current syntactic continuation, invoking a computation with a supplied continuation, and for creating a trivial (root) continuation.

Specification

The SRFI describes a set of core forms, and a set of derived forms that are definable in terms of the core forms.

The core forms are:

    syntax-run
    syntax-inspect
    syntax-return 
    syntax-do 
    define-syntax-computation
    let-syntax-computation
    letrec-syntax-computation
    computation-rules
    syntax-let/cc
    syntax-invoke/c
    syntax-root/c 
The derived forms are:
    syntax-error
    syntax-if
    syntax-if*
    syntax-match
    syntax-match*
    syntax-eq?
    syntax-symbol?
    syntax-atom?
    syntax-append
    syntax-map
    syntax-reverse
    syntax-foldl
    syntax-foldr
    syntax-temporaries

Core forms

The following forms should be provided. The semantics, which is informally described here, should conform to that of the reference implementation below:

Derived forms

The following forms should be provided. The semantics, which is informally described here, should conform to that of the reference implementation below:

Extended example

After the implementation below, we provide a more complex example implementing records with labeled fields featuring Here we just point out some highlights.

First, records are implemented as lists via the following definitions

  (define-syntax define-record
    (syntax-rules ()
      ((define-record name (make-name label ...))
       (begin 
         (define (make-name label ...)
           (list 'name label ...))
         (define-syntax-computation name
           (computation-rules ()
             ((name) (syntax-return (make-name (label ...))))))))))

  (define-record test (make-test x y))

  (define testing (make-test 8 9))

  testing  ;==> (8 9)
In the above, note that when defining the record type, we are binding the name, in this case test, to a syntax computation which, when invoked, will return a descriptor containing the name of the constructor, in this case make-test, and the labels, in this case x and y. This descriptor will be used for compile-time resolution of labels in match-record expressions.

For the matcher, we would like the expression

  (match-record testing
    (test (= y u) (= x v)) (list u v))           ;==> (9 8)
to expand at compile-time to
  (if (and (pair? testing)
           (eq? (car testing) 'test))
      (let ((fields (cdr testing)))
        (let ((v (car fields))
              (fields+ (cdr fields)))
          (let ((u (car fields+))
                (fields+ (cdr fields+)))
            (list u v))))
      (error "Record type does not match"))      ;==> (9 8)
where the fields are extracted in the correct order from the list. To do this, let's first define
  (define-syntax match-record
    (syntax-rules ()
      ((match-record val (name (= label var) ...) . body)
       (if (and (pair? val)
                (eq? (car val) 'name))
           (let ((fields (cdr val)))
             (syntax-run
               (syntax-match (name)
                 ((make-name labels)   
                  (match-fields fields
                                labels
                                ((= label var) ...)
                                ((= label var) ...)
                                body)))))
           (error "Record type does not match")))))
As promised, this macro extracts the descriptor information bound to the record name test, and then calls the workhorse, match-fields, which will extract the fields from the argument in the order they were listed in the original definition of the record type. Notice that to perform a syntax computation from an ordinary syntax-rules macro, we needed to use syntax-run.
  (define-syntax-computation match-fields
    (computation-rules ()
      ((match-fields fields labels () () body)
       (syntax-return (begin .  body)))
      ((match-fields fields (label* . labels*) () bindings body) 
       (syntax-do (rest <- (match-fields fields+ 
                                         labels*
                                         bindings
                                         bindings
                                         body))
                  (syntax-return 
                    (let ((fields+ (cdr fields)))
                      rest))))
      ((match-fields fields () ((= label var) . binds) bindings body)
       (syntax-error "No field" label "in record"))
      ((match-fields fields
                     (label* . labels*)
                     ((= label var) . binds)
                     bindings
                     body)
       (syntax-if (syntax-eq? label label*)  
                  (syntax-do
                    (new-bindings <- (remove-bind label* bindings))
                    (rest <- (match-fields fields+ 
                                           labels*
                                           new-bindings
                                           new-bindings
                                           body))
                    (syntax-return
                      (let ((var     (car fields))
                            (fields+ (cdr fields)))
                        rest)))
                  (match-fields fields 
                                (label* . labels*)
                                binds
                                bindings
                                body)))))
For each label in the descriptor, this macro scans through the bindings supplied in the match-record expression. If a match is found, the corresponding variable is bound to the datum at that point in the list. If not, we simply advance to the next label and the cdr of the list.

Notice how we are able to construct an s-expression piecemeal, in this case by binding part of it to rest and then inserting into the final expression. Also, notice that we can provide quite detailed syntax error messages.

The above macro uses the following simple helper computation to remove a binding from a list of bindings:

  (define-syntax-computation remove-bind
    (computation-rules () 
      ((remove-bind label* ())
       (syntax-return ()))
      ((remove-bind label* ((= label value) . bindings))
       (syntax-if (syntax-eq? label label*)
                  (syntax-return bindings)
                  (syntax-do (rest <- (remove-bind label* bindings))
                             (syntax-return ((= label value) . rest)))))))

Implementation

The reference implementation uses the macro mechanism of R5RS. It does not use any other SRFI or any library.

The implementation makes extensive use of techniques collected and published by Oleg Kiselyov and Al Petrofsky. Many of these are published on comp.lang.scheme, but see in particular [6] for the original version of one of the workhorses of the current implementation: syntax-rules level ??!lambda and ??!apply.

A collection of tests and examples is provided. These check some special cases of the mechanism defined in this SRFI. Passing the tests does not mean a correct implementation.

Reference implementation

;====================================================================
; Andre van Tonder 2004.

;--------------------------------------------------------------------
; First define some workhorses.  These are not part of the interface.

; Syntax-apply adapted from original by Oleg Kiselyov.
; Extended to do shadowing of syntax-do bound variables.

(define-syntax syntax-apply
  (syntax-rules (syntax-lambda)
    ((syntax-apply (syntax-lambda (bound-var . bound-vars) body) 
                   oval . ovals)
     (letrec-syntax
	 ((subs
	   (syntax-rules (bound-var syntax-lambda syntax-do <-)
	     ((_ val k bound-var)
	      (appl k val))
	     ((_ val k (syntax-lambda bvars int-body))
	      (subs-in-lambda val bvars (k bvars) int-body))
             ((_ val k (syntax-do (bvar <- comp) . comps)) 
	      (subs-in-do val (bvar) (k bvar comp) (syntax-do . comps)))
             ((_ val k (syntax-do k* (bvar <- comp) . comps)) 
	      (subs-in-do val (bvar) (k k* bvar comp) (syntax-do . comps)))
	     ((_ val k (x))	 
	      (subs val (recon-pair val k ()) x))
	     ((_ val k (x . y))
	      (subs val (subsed-cdr val k x) y))
	     ((_ val k x)	 
	      (appl k x))))
	  (subsed-cdr		 
	   (syntax-rules ()      
	     ((_ new-y val k x)
	      (subs val (recon-pair val k new-y) x))))
	  (recon-pair		 
	   (syntax-rules ()
	     ((_ new-x val k new-y)
	      (appl k (new-x . new-y)))))
	  (subs-in-lambda  
	   (syntax-rules (bound-var)
	     ((_ val () kp  int-body)
	      (subs val (recon-l kp) int-body))
             ((_ val (bound-var . obvars) (k bvars) int-body)
	      (appl k (syntax-lambda bvars int-body)))
             ((_ val (obvar . obvars) kp int-body)
	      (subs-in-lambda val obvars kp int-body))))
          (recon-l	 
	   (syntax-rules ()
	     ((_ result (k bvars))
	      (appl k (syntax-lambda bvars result)))))
          (subs-in-do
           (syntax-rules (bound-var)
             ((_ val () kp comp*)
              (subs val (subs-in-do* val kp) comp*))
             ((_ val (bound-var) (k bvar comp) comp*)
              (subs val (recon-do k bvar comp*) comp))
             ((_ val (bound-var) (k k* bvar comp) comp*)
              (subs val (recon-do val k k* bvar comp*) comp))
             ((_ val (obvar) kp comp*)
              (subs-in-do val () kp comp*))))
          (subs-in-do*
           (syntax-rules ()
             ((_ comp* val (k bvar comp))
              (subs val (recon-do k bvar comp*) comp))
             ((_ comp* val (k k* bvar comp))
              (subs val (recon-do val k k* bvar comp*) comp))))
          (recon-do
           (syntax-rules ()
             ((_ comp k bvar comp*)
              (appl k (syntax-do (bvar <- comp) comp*)))
             ((_ comp val k k* bvar comp*)
              (appl k (syntax-do k* (bvar <- comp) comp*)))))
	  (appl		    
	   (syntax-rules ()
             ((_ (f . args) result)
              (f result . args))))
	  (finish
	   (syntax-rules ()
	     ((_ exp () ())
	      exp)
	     ((_ exps rem-bvars rem-ovals)
	      (syntax-apply (syntax-lambda rem-bvars exps) . rem-ovals)))))
       (subs oval (finish bound-vars ovals) body)))))

; Alpha-renaming of syntax-level lambda expressions.
; Necessary to avoid accidental capture in cases like
;
; (define-syntax testing
;   (syntax-rules ()
;     ((testing a) (syntax-apply (syntax-lambda (x) '(x a)) 1))))
;
; (testing x)  ;==> (1 1) instead of (1 x)
;                 
; (define-syntax testing
;   (syntax-rules ()
;     ((testing a) (syntax-lambda-k
;                   (syntax-apply 1)
;                   (x) '(x a)))))
;
; (testing x) ;==> (1 x)
;
; Main reason for this is to obviate the need to indicate syntactic
; variables with special identifiers, e.g. (??! x) as done by Oleg. 

(define-syntax syntax-lambda-k
  (syntax-rules ()
    ((syntax-lambda-k (form . args) (x) exp)
     (let-syntax ((replace
                   (syntax-rules ()
                     ((replace x)
                      (form (syntax-lambda (x) exp) . args)))))
       (replace temp)))))

;=====================================================================
; The core forms:
; Only those listed in the SRFI specification are part of the
; interface.  The rest should be hidden by a module system.

(define-syntax define-syntax-computation
  (syntax-rules (computation-rules)
    ((define-syntax-computation name
       (computation-rules (lit ...)
         ((*name . pat) computation)
         ...))
     (define-syntax name 
       (syntax-rules (lit ...)
         ((*name k . pat) (syntax-bind k computation))
         ...)))))

(define-syntax let-syntax-computation
  (syntax-rules (computation-rules)
    ((let-syntax-computation k ((name
                                 (computation-rules (lit ...)
                                   ((*name . pat) computation)
                                   ...))
                                ...)
       computation*)
     (let-syntax ((name 
                   (syntax-rules (lit ...)
                     ((*name k* . pat) (syntax-bind k* computation))
                     ...))
                  ...)
       (syntax-bind k computation*)))))

(define-syntax letrec-syntax-computation
  (syntax-rules (computation-rules)
    ((letrec-syntax-computation k ((name
                                    (computation-rules (lit ...)
                                      ((*name . pat) computation)
                                      ...))
                                   ...)
       computation*)
     (letrec-syntax ((name 
                      (syntax-rules (lit ...)
                        ((*name k* . pat) (syntax-bind k* computation))
                        ...))
                     ...)
       (syntax-bind k computation*)))))

(define-syntax syntax-bind
  (syntax-rules ()
    ((syntax-bind k ((computation-rules lits . body) . args))
     (syntax-call k (computation-rules lits . body) . args))
    ((syntax-bind k (form . body)) (form k . body))))

(define-syntax syntax-let/cc
  (syntax-rules ()
    ((syntax-let/cc k k* computation)
     (syntax-lambda-k (syntax-apply k)
                      (k*) (syntax-bind k computation)))))

(define-syntax syntax-invoke/c
  (syntax-rules ()
    ((syntax-invoke/c k continuation computation)
     (syntax-bind continuation computation))))

(define-syntax syntax-root/c
  (syntax-rules ()
    ((syntax-root/c k)
     (let-syntax ((return
                   (syntax-rules ()
                     ((return x k*) (syntax-return k* x)))))
       (syntax-lambda-k (return k)
                        (x) x)))))

(define-syntax syntax-return
  (syntax-rules ()
    ((syntax-return k exp) (syntax-apply k exp))))

(define-syntax syntax-do
  (syntax-rules (<-)
    ((syntax-do k computation)
     (syntax-bind k computation))
    ((syntax-do k (x <- computation) . computations)
     (syntax-lambda-k (syntax-bind computation)
                      (x) (syntax-do k . computations)))))

(define-syntax syntax-run
  (syntax-rules ()
    ((syntax-run computation)
     (syntax-lambda-k (syntax-bind computation)
                      (x) x))))

(define-syntax syntax-inspect
  (syntax-rules ()
    ((syntax-inspect computation)
     (syntax-lambda-k (syntax-bind computation)
                      (x) 'x))))

(define-syntax-computation syntax-call
  (computation-rules (computation-rules _)
    ((syntax-call (computation-rules lits
                    ((_ . pat) computation)
                    ...)
                  . exps)
     (let-syntax-computation
         ((f (computation-rules lits
               ((f . pat) computation)
               ...)))
       (f . exps)))
    ((syntax-call (computation-rules . rest) . exps)
     (syntax-error (syntax-call (computation-rules . rest) . exps)))
    ((syntax-call f . exps)
     (f . exps))))

;=================================================================
; The derived forms:

(define-syntax-computation syntax-error
  (computation-rules ()
    ((syntax-error . args)
     (syntax-do (quit <- (syntax-root/c))
                (syntax-invoke/c quit
                  (syntax-return              
                   (let-syntax
                       ((error
                         (syntax-rules (key)
                           ((error key) unreached))))
                     (error . args))))))))

; Adapted from Hilsdale and Friedman

(define-syntax-computation syntax-eq?
  (computation-rules ()
    ((syntax-eq? x y)
     (syntax-if (syntax-symbol? x)
                (let-syntax-computation 
                    ((test (computation-rules (x)
                             ((test x)     (syntax-return #t))
                             ((test non-x) (syntax-return #f)))))
                  (test y))
                (syntax-if (syntax-atom? x)   
                           (syntax-match* y
                             (x     (syntax-return #t))
                             (non-x (syntax-return #f)))
                           (syntax-return #f))))))

; Adapted from Oleg Kiselyov 

(define-syntax-computation syntax-symbol?
  (computation-rules ()
    ((syntax-symbol? (x . y))  (syntax-return #f))
    ((syntax-symbol? #(x ...)) (syntax-return #f))
    ((syntax-symbol? x)
     (let-syntax-computation
         ((test (computation-rules ()
                  ((test x) (syntax-return #t))
                  ((test y) (syntax-return #f)))))
       (test foo)))))

(define-syntax-computation syntax-atom?
  (computation-rules ()
    ((syntax-atom? (x . y))  (syntax-return #f))
    ((syntax-atom? #(x ...)) (syntax-return #f))
    ((syntax-atom? x)        (syntax-return #t))))
   
(define-syntax-computation syntax-if
  (computation-rules ()
    ((syntax-if sc x y) 
     (syntax-do (s <- sc)
                (syntax-if* s x y)))))

(define-syntax-computation syntax-if*
  (computation-rules ()
    ((syntax-if* #f x y) y) 
    ((syntax-if* truish x y) x)))

(define-syntax-computation syntax-match
  (computation-rules ()
    ((syntax-match sc (pat computation) ...)
     (syntax-do (s <- sc)
                (syntax-match* s (pat computation) ...)))))
                
(define-syntax-computation syntax-match*
  (computation-rules ()
    ((syntax-match* s (pat computation) ...)
     (let-syntax-computation
         ((f (computation-rules ()
               ((f pat) computation)
               ...)))
       (f s)))))

(define-syntax-computation syntax-temporaries
  (computation-rules ()
    ((syntax-temporaries lst)      (syntax-temporaries lst ()))
    ((syntax-temporaries () temps) (syntax-return temps))
    ((syntax-temporaries (h . t) temps)
     (syntax-temporaries t (temp . temps)))))

(define-syntax-computation syntax-append
  (computation-rules ()
    ((syntax-append () y)      (syntax-return y))
    ((syntax-append (h . t) y) (syntax-do (rest <- (syntax-append t y))
                                          (syntax-return (h . rest))))))

(define-syntax-computation syntax-map
  (computation-rules ()
    ((syntax-map f ())      (syntax-return ()))
    ((syntax-map f (h . t)) (syntax-do (x <- (f h))
                                       (y <- (syntax-map f t))
                                       (syntax-return (x . y))))))

(define-syntax-computation syntax-reverse
  (computation-rules ()
    ((syntax-reverse s)                 
     (letrec-syntax-computation
         ((syntax-reverse*
           (computation-rules ()
             ((syntax-reverse* () accum) (syntax-return accum))
             ((syntax-reverse* (h . t) accum)
              (syntax-reverse* t (h . accum))))))
       (syntax-reverse* s ())))))

(define-syntax-computation syntax-foldl
  (computation-rules ()
    ((syntax-foldl f seed ())
     (syntax-return seed))
    ((syntax-foldl f seed (h . t))
     (syntax-do (x <- (f h seed))
                (syntax-foldl f x t)))))

(define-syntax-computation syntax-foldr
  (computation-rules ()
    ((syntax-foldr f seed ())
     (syntax-return seed))
    ((syntax-foldr f seed (h . t))
     (syntax-do (seed* <- (syntax-foldr f seed t))
                (f h seed*)))))

Test suite

;==============================================================
; Tests:

; Test proper shadowing, etc. in syntax-do. 

(syntax-run (syntax-do (x <- (syntax-return 1))
                       (syntax-return x)))              ;==> 1

(syntax-run (syntax-do (x <- (syntax-return 1))
                       (syntax-do (x <- (syntax-return 2))
                                  (syntax-return x))))  ;==> 2

(syntax-run (syntax-do (x <- (syntax-return 1))
                       (x <- (syntax-return 2))
                       (syntax-return x)))              ;==> 2

(syntax-run (syntax-do (x <- (syntax-return 1))
                       (syntax-do (y <- (syntax-return x))
                                  (syntax-return y))))  ;==> 1

(syntax-run (syntax-do (x <- (syntax-return 1))
                       (y <- (syntax-return x))
                       (syntax-return y)))              ;==> 1

(syntax-inspect (syntax-do (x <- (syntax-return 1))
                           (y <- (syntax-return 2))
                           (syntax-return (x y))))      ;==> (1 2)
       ;==>  (1 2)

(syntax-run (syntax-do (x <- (syntax-return 1))
                       (syntax-do (y <- (syntax-return 2))
                                  (syntax-return x))))  ;==> 1

; Notice the scopings here - syntax-do can be flattened without
; changing the semantics:

(syntax-inspect (syntax-if (syntax-do (x <- (syntax-return #t))
                                      (syntax-return x))
                           (syntax-return x)
                           (syntax-return 2)))          ;==> #t 
                    ;==> #t

(syntax-inspect (syntax-do (x <- (syntax-do (y <- (syntax-return 1))
                                            (syntax-return 2)))
                           (syntax-return y)))          ;==> 1


(syntax-inspect (syntax-if (syntax-do (x <- (syntax-return #t))
                                      (syntax-return x))
                           (syntax-return x)
                           (syntax-return 2)))          ;==> #t

; Test correct binding of colored identifiers.
; The behavior of the following:

(define-syntax-computation test
  (computation-rules ()
    ((test exp var)
     (syntax-do (new-var <- (syntax-return var))
                (syntax-return    
                  (let ((new-var 1)) exp))))))

(syntax-run (test x x))   ;==> 1

; is the same as with-syntax: 

; (define-syntax test
;   (lambda (stx)
;     (syntax-case stx ()
;       ((test exp var)
;        (with-syntax ((new-var (syntax var)))
;          (syntax
;             (let ((new-var 1)) var)))))))
;
; (test x x)  ;==> 1

; Also,

(define-syntax-computation test
  (computation-rules ()
    ((test var)
     (syntax-do (body <- (syntax-return (cons var var)))
                (syntax-return    
                  (let ((var 1)) body))))))

(syntax-run (test x))    ;==> (1 . 1)

; is the same as with-syntax: 

; (define-syntax test
;   (lambda (stx)
;     (syntax-case stx ()
;       ((test var)
;        (with-syntax ((body (syntax (cons var var))))
;          (syntax
;             (let ((var 1)) body)))))))

; (test x)

; Another test of hygiene, here with an anonymous computation.
; The inner x should not capture the outer x:

(define-syntax-computation test
  (computation-rules ()
    ((test a) ((computation-rules ()
                 ((_ x) (syntax-return '(x a))))
               1))))

(syntax-run (test x))   ;==> (1 x)

; A simple use of an anonymous computation

(syntax-inspect ((computation-rules ()
                   ((_ x) (syntax-return (x x))))
                 1))                               ;==> (1 1)

; Anonymous computations - note the scoping here - this
; tests whether the argument is a symbol

(syntax-inspect
 ((computation-rules ()
    ((_ x) ((computation-rules ()
              ((_ x) (syntax-return #t))
              ((_ y) (syntax-return #f)))
            foo)))
  symbol))                                         ;==> #t

; Computation-rules does introduce a new color scope

(syntax-inspect ((computation-rules ()
                   ((_ a) (syntax-do (x <- (syntax-return 1))
                                     (syntax-return (x a)))))
                 x))

       ;==> (1 x)

; Simple test of let-syntax-computation:

(syntax-run
 (let-syntax-computation
   ((atom?
     (computation-rules ()
       ((atom? (x . y))        (syntax-return #f))
;      ((atom? #(x (... ...))) (syntax-return #f))    ; non-standard
       ((atom? x)              (syntax-return #t)))))
   (atom? (x y))))
                                       ;==> #f

(syntax-run (syntax-atom? x))          ;==> #t
(syntax-run (syntax-atom? (1 . 2)))    ;==> #f

; Simple tests of list primitives

(syntax-run (syntax-append (list 1 2) (4 5 7)))  ;==> (1 2 4 5 7)

(syntax-run (syntax-reverse (1 2 3 5 list)))     ;==> (5 3 2 1)

; syntax-eq?

(syntax-run (syntax-eq? x x))              ;==> #t
(syntax-run (syntax-eq? x y))              ;==> #f
(syntax-run (syntax-eq? x 1))              ;==> #f
(syntax-run (syntax-eq? #t x))             ;==> #f
(syntax-run (syntax-eq? #t #t))            ;==> #t
(syntax-run (syntax-eq? (x . y) (x . y)))  ;==> #f

; conditionals:

(syntax-run (syntax-if (syntax-return #f)
                       (syntax-return 1)
                       (syntax-return 2)))  ;==> 2

(syntax-run (syntax-if (syntax-eq? x x)
                       (syntax-return 1)
                       (syntax-return 2)))  ;==> 1

(syntax-inspect (syntax-match* (a b c)
                  ((h . t) (syntax-return t))
                  (other   (syntax-error "Not a list"))))  ;==> (b c)

; Temporaries

(syntax-inspect (syntax-temporaries (x y z)))  ;==> (temp~1 temp~2 temp~3) 

; Predicates

(syntax-run (syntax-symbol? x))     ;==> #t
(syntax-run (syntax-symbol? 1))     ;==> #f
(syntax-run (syntax-symbol? (x y))) ;==> #f

(syntax-run (syntax-atom? 1))        ;==> #t
(syntax-run (syntax-atom? (1 . 2)))  ;==> #f

; Using first-order computations 

(syntax-inspect (syntax-map syntax-atom? (x y (z u) v))) ;==>  (#t #t #f #t)

(syntax-inspect (syntax-map syntax-reverse ((1 2) (3 4))))

                           ;==>  ((2 1) (4 3))

(syntax-inspect (syntax-map 
                   (computation-rules ()
                     ((_ x) (syntax-return (x x))))
                   (1 2 3)))                        ;==> ((1 1) (2 2) (3 3))

(syntax-inspect (syntax-map syntax-reverse
                            ((1 2) (3 4))))   ;==> ((2 1) (4 3))

(syntax-inspect (syntax-foldl syntax-append
                              ()
                              ((1 2) (3 4)))) ;==> (3 4 1 2)

(syntax-inspect (syntax-foldr syntax-append
                              ()
                              ((1 2) (3 4)))) ;==> (1 2 3 4)

; Capturing and invoking continuations to break loop

(define-syntax-computation all-true?
  (computation-rules ()
    ((all-true? ls)
     (syntax-let/cc break
       (syntax-foldl (computation-rules ()
                       ((_ #f seed) (syntax-invoke/c break
                                      (syntax-return #f)))
                       ((_ #t seed) (syntax-return #t)))
                     #t
                     ls)))))

(syntax-run (all-true? (#t #f #t #t)))  ;==> #f

; Using root-continuation to escape altogether

(define-syntax-computation first 
  (computation-rules ()
    ((first (h . t)) (syntax-return h))
    ((first other)   (syntax-do (quit <- (syntax-root/c))
                                (syntax-invoke/c quit
                                   (syntax-return "First of non-pair"))))))

(syntax-inspect (syntax-map first ((a b) (c d))))   ;==> (a c)
(syntax-inspect (syntax-map first (a (b c))))       ;==> "First of non-pair"

; Using syntax-error

(define-syntax-computation first 
  (computation-rules ()
    ((first (h . t)) (syntax-return h))
    ((first other)   (syntax-error "First of non-pair " other))))


(syntax-inspect (syntax-map first ((a b) (c d))))   ;==> (a c)
(syntax-inspect (syntax-map first (a (b c))))

               ;==> error: bad syntax in: (error "First of non-pair " a) 

Example - records with labeled fields

;======================================================================
; More complex example:
; Records with labeled fields implementing:
;    - Compile-time constructing by label
;    - Compile-time matching by label

(define-syntax define-record
  (syntax-rules ()
    ((define-record name (make-name label ...))
     (begin 
       (define (make-name label ...)
         (list 'name label ...))
       (define-syntax-computation name
         (computation-rules ()
           ((name) (syntax-return (make-name (label ...))))))))))

(define-syntax make-record
  (syntax-rules (=)
    ((make-record name (= label value) ...)
     (syntax-run 
       (syntax-match (name)
         ((make-name labels) (populate make-name
                                       labels 
                                       ((= label value) ...)
                                       ((= label value) ...)
                                       ())))))))

(define-syntax-computation populate
  (computation-rules (=)
    ((populate make-name () () bindings (value* ...))
     (syntax-return (make-name value* ...)))
    ((populate make-name (label* . labels*) () bindings values*)
     (syntax-error "No binding for" label* "in" make-name bindings))
    ((populate make-name () ((= label value) . rest) bindings values*)
     (syntax-error "Wrong label" label "in" make-name bindings))
    ((populate make-name
               (label* . labels*) 
               ((= label value) . binds) 
               bindings
               (value* ...))
     (syntax-if (syntax-eq? label label*)
                (syntax-do (new-bindings <- (remove-bind label* bindings))
                           (populate make-name
                                     labels*
                                     new-bindings
                                     new-bindings
                                     (value* ... value)))
                (populate make-name
                          (label* . labels*)
                          binds
                          bindings
                          (value* ...))))))

(define-syntax-computation remove-bind
  (computation-rules () 
    ((remove-bind label* ())
     (syntax-return ()))
    ((remove-bind label* ((= label value) . bindings))
     (syntax-if (syntax-eq? label label*)
                (syntax-return bindings)
                (syntax-do (rest <- (remove-bind label* bindings))
                           (syntax-return ((= label value) . rest)))))))

(define-syntax match-record
  (syntax-rules ()
    ((match-record val (name (= label var) ...) . body)
     (if (and (pair? val)
              (eq? (car val) 'name))
         (let ((fields (cdr val)))
           (syntax-run
             (syntax-match (name)
               ((make-name labels)   
                (match-fields fields
                              labels
                              ((= label var) ...)
                              ((= label var) ...)
                              body)))))
         (error "Record type does not match")))))

(define-syntax-computation match-fields
  (computation-rules ()
    ((match-fields fields labels () () body)
     (syntax-return (begin .  body)))
    ((match-fields fields (label* . labels*) () bindings body) 
     (syntax-do (rest <- (match-fields fields+ 
                                       labels*
                                       bindings
                                       bindings
                                       body))
                (syntax-return 
                  (let ((fields+ (cdr fields)))
                    rest))))
    ((match-fields fields () ((= label var) . binds) bindings body)
     (syntax-error "No field" label "in record"))
    ((match-fields fields
                   (label* . labels*)
                   ((= label var) . binds)
                   bindings
                   body)
     (syntax-if (syntax-eq? label label*)  
                (syntax-do
                  (new-bindings <- (remove-bind label* bindings))
                  (rest <- (match-fields fields+ 
                                          labels*
                                          new-bindings
                                          new-bindings
                                          body))
                  (syntax-return
                     (let ((var     (car fields))
                           (fields+ (cdr fields)))
                       rest)))
                (match-fields fields 
                              (label* . labels*)
                              binds
                              bindings
                              body)))))

;---------------------------------------------------------------
; Tests:

(define-record test (make-test x y))

; Now the following:

(make-record test (= y 5) (= x 6))   ;==> (test 6 5)

; expands at compile-time to

(make-test 6 5)                      ;==>  ;==> (test 6 5)

(make-record test (= x 5) (= y 6))   ;==> (test 5 6)

(make-record test (= y (make-record test (= x 1) (= y 2)))
                  (= x 7))
                                     ;==> (test 7 (test 1 2))

(make-record test (= y 5) (= x 6) (= w 1))

     ;==> error: bad syntax in: (error "Wrong label" w "in" make-test ((= w 1)))

(define testing (make-test 8 9))

; Now the following:

(match-record testing
  (test (= y u) (= x v)) (list u v))           ;==> (9 8)

; expands at compile-time to: 

(if (and (pair?  testing)
         (eq? (car testing) 'test))
    (let ((fields (cdr testing)))
      (let ((v (car fields))
            (fields+ (cdr fields)))
        (let ((u (car fields+))
              (fields+ (cdr fields+)))
          (list u v))))
    (error "Record type does not match"))      ;==> (9 8)

(match-record testing
  (test (= x u)) u)                            ;==> 8

(match-record testing
  (test (= y u)) u)                            ;==> 9

(match-record testing
  (test (= x u) (= y v)) (list u v))           ;==> (8 9)

(match-record testing
  (test (= y u) (= x v) (= z w)) (cons u v))

          ;==>  error: bad syntax in: (error "No field" z "in record")

; Check that make-record can be used in other macros without confusion:

(define-syntax test-compose
  (syntax-rules (x y)
    ((test-compose v w) (make-record test (= x v) (= y w)))))


(make-record test (= y 1) (= x (test-compose 7 7)))

               ;==> (test (test 7 7) 1)

(test-compose (make-record test (= x 5) (= y 7)) 4)

               ;==>  (test (test 5 7) 4)

(test-compose (test-compose 3 4) 5)  ;==> (test (test 3 4) 5)

References

[1]
  Richard Kelsey, William Clinger, and Jonathon Rees (editors).
  The Revised^5 Report on the Algorithmic Language Scheme
  Higher-Order and Symbolic Computation, Vol. 11, No. 1, September,
    1998, and ACM SIGPLAN Notices, Vol. 33, No. 9, October, 1998.
  http://www.schemers.org/Documents/Standards/R5RS/

[2]
  Erik Hilsdale and Daniel P. Friedman.
  Writing Macros in Continuation-Passing Style
  Scheme and Functional Programming 2000, September, 2000.
  http://www.ccs.neu.edu/home/matthias/Scheme2000/hilsdale.ps

[3]
  R. Kent Dybvig.
  Writing Hygienic Macros in Scheme with SYNTAX-CASE.
  Technical Report 356, Indiana University, Bloomington, Indiana, June
    1992.
  http://citeseer.nj.nec.om/dybvig92writing.html

[4]
  E. Moggi,
  Notions of Computation and Monads,
  Information and Computation 93 (1) 1991. 

[5]
  Philip Wadler,
  Monads for Functional Programming,
  In M. Broy, editor, Marktoberdorf Summer School on Program Design Calculi, 
  Springer Verlag, NATO ASI Series F: Computer and systems sciences, 
  Volume 118, August 1992. 
  Also in J. Jeuring and E. Meijer, editors, Advanced Functional Programming, 
  Springer Verlag, LNCS 925, 1995. Some errata fixed August 2001.

[6]
  Oleg Kiselyov,
  Syntax-rule-level ??!lambda and ??!apply,
  http://okmij.org/ftp/Scheme/macros.html#Macro-lambda
  

Copyright

Copyright (C) André van Tonder (2004). All Rights Reserved.

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.


Author: Andre van Tonder
Editor: David Van Horn
Last modified: Sun Jan 28 13:40:37 MET 2007