From posting-system@google.com Wed Feb  6 18:21:58 2002
Date: Wed, 6 Feb 2002 16:21:50 -0800
From: oleg@pobox.com (oleg@pobox.com)
Newsgroups: comp.lang.scheme
Subject: Scheme procedure -> R5RS macro, by example of quotify
Message-ID: <7eb8ac3e.0202061621.755885a9@posting.google.com>
Status: OR

The recently posted question about writing a 'quotify' macro gives an
opportunity to demonstrate _systematical_ construction of complex R5RS
macros. We start by implementing the algorithm of the required
S-expression transformation as a regular Scheme procedure. Scheme
procedures are relatively easy to test and debug. When the algorithm
is tested, we largely _mechanically_ convert the Scheme procedure into
a R5RS macro. The resulting macro may not be very efficient; still,
the approach may still be worth it taking into account the overall
development time. Macros are notoriously difficult to debug. For
completeness and comparison purposes, we also show a low-level macro
implementation of 'quotify'.

It should be emphasized that the resulting R5RS macro is modular. It
is built from separate small pieces that have been be written and
tested independently.

The conversion of a procedure to a macro has indeed been done rather
mechanically. I was tired last night and didn't think much when doing
the conversion. Nevertheless, all R5RS macros worked either the first
time, or after I fixed a few typos and other minor errors (like typing
kt when I meant kf). Usually R5RS macros require far more debugging
than mere correction of spelling errors.

The rest of the article is organized as follows:
	- The statement of the problem
	- Procedural solution: quotify-fn
	- Converting quotify-fn into a low-level macro quotify-ll
	- Rewriting quotify-fn in CPS and converting quotify-fn into
	  an R5RS macro ?quotify
	  - CPS primitives cons-cps, car-cps, cdr-cps, ifpair?
	    and their R5RS counterparts
	  - CPS primitive ifeq? and its R5RS macro counterpart ?ifeq?
	  - Using primitives: CPS function memq-cps and its R5RS macro
	    counterpart ?memq
	  - CPS higher-order combinator map-cps and its R5RS macro
	    counterpart ?map
	  - CPS function quotify-cps and its R5RS macro counterpart
	    ?quotify

All the code has been tested on Bigloo 2.4b.

* The statement of the problem

We have to write a macro quotify that should work as follows:
 (quotify (i j k) (4 k 5 l () (m i) ((('i)))))
 ==> `(4 ,k 5 l () (m ,i) (((',i))))

The problem is to take an S-expression representing a tree and
non-destructively modify selected leaf nodes. To be more precise, we
have to take a Scheme expression and selectively unquote certain
symbols.

* Procedural solution: quotify-fn

First we develop the required transformation as a regular Scheme
procedure.

(define (quotify-fn symbs-l tree)
  (define (doit tree)
    (map 
     (lambda (node)
       (if (pair? node)
	 ; recurse to process children
	   (doit node)
	   (if (memq node symbs-l)
	     ; replace the leaf
	       (list 'unquote node)
	       node)))
     tree))
  (list 'quasiquote (doit tree)))

; test
(display (quotify-fn '(i j k) '(4 k 5 l () (m i) ((('i))))))
(newline)

; The above code prints
	`(4 ,k 5 l () (m ,i) (((',i))))


* Converting quotify-fn into a low-level macro quotify-ll

(define-macro (quotify-ll symbs-l tree)
  (define (doit tree)
    (map 
     (lambda (node)
       (if (pair? node)
	 ; recurse to process children
	   (doit node)
	   (if (memq node symbs-l)
	     ; replace the leaf
	       (list 'unquote node)
	       node)))
     tree))
  (list 'quasiquote (doit tree)))


To test that the unquoting really works, we evaluate the following code:

(let ((i 'symbol-i) (j "str-j") (k "str-k"))
  (display (quotify-ll (i j k) (4 k 5 l () (m i) ((('i))))))
  (newline))

which prints
	(4 str-k 5 l () (m symbol-i) ((('symbol-i)))) 


This proves that identifiers i, j and k have indeed been 'unquoted'.

* Rewriting quotify-fn in CPS and converting quotify-fn into an R5RS macro

** CPS primitives cons-cps, car-cps, cdr-cps, ifpair? and their R5RS
** counterparts 

To convert quotify-fn into an R5RS macro, we have to re-write the
procedure into CPS. But first we need CPS versions of Scheme
primitives, such as car, cdr, etc. We will develop these primitives
and the corresponding R5RS macros in parallel. To distinguish the
names of R5RS macros, we begin the names with '?'.
The CPS R5RS macros rely on macro-lambda (specifically, on a R5RS macro
??!apply and notations ??!lambda and ??!). The latter are explained
and defined in
	http://pobox.com/~oleg/ftp/Scheme/syntax-rule-CPS-lambda.txt


; cons A LST K
; pass (A . LST) to K

(define (cons-cps a b k)
  (k (cons a b)))

(define-syntax ?cons
  (syntax-rules ()
    ((_ x y k)
     (??!apply k (x . y)))))

; Pass to K the first or the second element of a given pair

(define (car-cps x k)
  (k (car x)))

(define (cdr-cps x k)
  (k (cdr x)))

(define-syntax ?car
  (syntax-rules ()
    ((_ (x . y) k) (??!apply k x))))

(define-syntax ?cdr
  (syntax-rules ()
    ((_ (x . y) k) (??!apply k y))))

; Check to see if x is a pair. If it is, apply kt to x; otherwise,
; apply kf to x
(define (ifpair? x kt kf)
  (if (pair? x) (kt x) (kf x)))

(define-syntax ?ifpair? 
  (syntax-rules ()
    ((_ (a . b) kt kf)
     (??!apply kt (a . b)))
    ((_ non-pair kt kf)
     (??!apply kf non-pair))))


** CPS primitive ifeq? and its R5RS macro counterpart ?ifeq?

; if (eq? a b), apply kt to a
; otherwise, apply kf to a

(define (ifeq? a b kt kf)
  (if (eq? a b) (kt a) (kf a)))

; ?ifeq? a b kt kf
; Here we cut corners a little bit: if 'a' is not a symbol, 
; we always assume mismatch. R5RS gives an implementation a freedom
; to eq? numbers and literal pairs and strings as the implementation
; sees fit.
; This is the only piece that requires care. But it's small, and can be
; debugged separately -- independent of other code.

(define-syntax ?ifeq?
  (syntax-rules ()
    ((_ (x . y) b kt kf) ; a is not a symbol: always false
     (??!apply kf (x . y)))
    ((_ () b kt kf) ; a is not a symbol: always false
     (??!apply kf ()))
    ((_ a b _kt _kf)
     (let-syntax
	 ((aux 
	   (syntax-rules (a)
	     ((_ a kt kf)
	      (??!apply kt a))
	     ((_ other kt kf)
	      (??!apply kf a)))))
       (aux b _kt _kf)))))

; Test code
(?ifeq? i i 
       (??!lambda (r) (begin (display "OK:") (display '(??! r)) (newline)))
       (??!lambda (r) (begin (display "FAIL:") (display '(??! r)) (newline)))
)
(?ifeq? i j
       (??!lambda (r) (begin (display "OK:") (display '(??! r)) (newline)))
       (??!lambda (r) (begin (display "FAIL:") (display '(??! r)) (newline)))
)


** Using primitives: CPS function memq-cps and its R5RS macro counterpart ?memq

; if a occurs in lst, pass the sublist to kt. Otherwise, pass () to kf
(define (memq-cps a lst kt kf)
  (ifpair? lst
    (lambda (lst) ; it's a pair
      (car-cps lst
	(lambda (x)
	  (ifeq? a x
	    ; match
	    (lambda (_) (kt lst))
	    ; mismatch
	    (lambda (_)
	      (cdr-cps lst
		(lambda (tail)
		  (memq-cps a tail kt kf))))))))
    (lambda (empty)
      (kf empty))))

; Test code
(memq-cps 'i '(j k l)
	  (lambda (r) (display "OK:") (display r) (newline))
	  (lambda (r) (display "FAIL:") (display r) (newline))
) ; prints: FAIL:() 

(memq-cps 'i '(j i l)
	  (lambda (r) (display "OK:") (display r) (newline))
	  (lambda (r) (display "FAIL:") (display r) (newline))
) ;  prints: OK:(i l)


(define-syntax ?memq 
  (syntax-rules ()
    ((_ a lst kt kf)
     (?ifpair? lst
	(??!lambda (lst) ; it's a pair
	 (?car lst
	  (??!lambda (x)
	   (?ifeq? a (??! x)
	    ; match
	    (??!lambda (_) (??!apply kt (??! lst)))
	    ; mismatch
	    (??!lambda (_)
	      (?cdr lst
		(??!lambda (tail)
		  (?memq a (??! tail) kt kf))))))))
    (??!lambda (empty)
      (??!apply kf (??! empty)))))))

Please note the similarity between memq-cps and ?memq

; Test code
(?memq i (j k l)
       (??!lambda (r) (begin (display "OK:") (display '(??! r)) (newline)))
       (??!lambda (r) (begin (display "FAIL:") (display '(??! r)) (newline)))
) ; prints: FAIL:()

(?memq i (j i l)
       (??!lambda (r) (begin (display "OK:") (display '(??! r)) (newline)))
       (??!lambda (r) (begin (display "FAIL:") (display '(??! r)) (newline)))
) ; prints: OK:(i l)



** CPS higher-order combinator map-cps and its R5RS macro counterpart ?map

; Map a CPS function f on a list
; map f () => ()
; map f (x . tail) => (f x . map f tail)

(define (map-cps f lst k)
  (ifpair? lst
     ; lst still has elements
     (lambda (lst)
       (car-cps lst
	  (lambda (x)
	    (f x
	       (lambda (fx)
		 (cdr-cps lst
		    (lambda (tail)
		      (map-cps f tail
			       (lambda (res)
				 (cons-cps fx res k))))))))))
     ; lst is empty
     (lambda (empty)
       (k empty))))

; Test code
(map-cps (lambda (x k) (k (+ 1 x))) '(1 2 3 4) display)
(newline)

; We re-use a previously written code for ?map, which is slightly
; more optimal than the direct translation of the above

(define-syntax ?map
  (syntax-rules ()
    ((_ f () k)
     (??!apply k ()))
    ((_ f (x . rest) k)
     (f x
      (??!lambda (new-x)
	 (?map f rest
	   (??!lambda (new-rest)
	     (?cons (??! new-x) (??! new-rest) k))))))))


** CPS function quotify-cps and its R5RS macro counterpart ?quotify

We now have all the pieces to solve the problem:


(define (quotify-cps symbs-l tree k)
  (define (doit tree k)
    (map-cps
     (lambda (node k)
       (ifpair? node
	 ; recurse to process children
	 (lambda (node)
	   (doit node k))
	 (lambda (node) ; node is not a pair
	   (memq-cps node symbs-l
	     ; matches
	     (lambda (_) (k (list 'unquote node)))
	     ; mis-matches: leave the node alone
	     (lambda (_) (k node))))))
     tree
     k))
  (doit tree (lambda (conv-tree) (k (list 'quasiquote conv-tree)))))


; Test code
(quotify-cps '(i j k) '(4 k 5 l () (m i) ((('i)))) display)
(newline)

The code prints:
  (quasiquote (4 (unquote k) 5 l () (m (unquote i)) ((((quote (unquote i)))))))

The corresponding CPS macro:

(define-syntax ?quotify
  (syntax-rules (quasiquote unquote)
  ((_ symbs-l _tree _k)
   (letrec-syntax
       ((fn			; function to map
	 (syntax-rules (unquote)
	   ((_ node k)
	    (?ifpair? node
					; recurse to process children
		(??!lambda (node1)
		    (doit (??! node1) k))
		(??!lambda (node1) ; node is not a pair
		    (?memq (??! node1) symbs-l
					; matches
		      (??!lambda (_) (??!apply k (unquote (??! node1))))
					; mis-matches: leave the node alone
		      (??!lambda (_) (??!apply k (??! node1)))))))))
	(doit
	 (syntax-rules ()
	   ((_ tree k)
	    (?map fn tree k)))))
     (doit _tree
	   (??!lambda (conv-tree) 
		      (??!apply _k (quasiquote (??! conv-tree)))))))))

We only have to watch for shadowing of the names of pattern variables.
It's best avoiding it. We can rename bound variables manually, or just
pass the code through an alpha-converter.

; Test code
(let ((i 'symbol-i) (j "str-j") (k "str-k"))
  (display (?quotify (i j k) (4 k 5 l () (m i) ((('i))))
		     ; The following is sort of (lambda (x) x)
		     ; that is, the top level continuation of
		     ; every CPS function
		     (??!lambda (r) (begin (??! r)))))
  (newline))

When evaluated ("bigloo -i -hygien a.scm"), the test code prints,
after a few minutes, the desired result
	(4 str-k 5 l () (m symbol-i) ((((quote symbol-i)))))

The resulting ?quote R5RS macro isn't fast. However we have not yet
made any attempt to optimize the underlying ??!apply macro, which is
being used extensively.

Thus contrary to the ordinary experience, R5RS macros can indeed look
just like regular Scheme procedures.