Scheme->syntax-rules [Was: hygienic macro primality tester]
Author Message Scheme->syntax-rules [Was: hygienic macro primality tester]

A more systematic way of writing syntax-rules macros is to
mechanically convert the corresponding Scheme procedures. Scheme
functions are far easier to develop and debug. After we are sure our
Scheme code works, we submit our procedures to a
Scheme--to--syntax-rules compiler -- and use but don't look at the
tester syntax-rule macro based on the Eratosthenes sieve. This
approach also helps Joe Marshall, who wrote "I'm in need of an
INTERCAL compiler written in SYNTAX-RULES" Well, he can just compile
the existing INTERCAL compiler to syntax-rules.

* Eratosthenes sieve
* Pure-functional, generic implementation of the Eratosthenes sieve
* Compilation of the Scheme implementation to syntax-rules macros

* Eratosthenes sieve

We should first remark that most of the examples of the Eratosthenes
sieve -- in particular, the examples in Haskell distributions -- are
incorrect. They mis-represent the sieve algorithm. The beauty of the
Eratosthenes sieve is the complete absence of division (or related
'mod') operations. A division-free algorithm was quite an advantage in
ancient times. This fact lets us encode the primality testing with the
minimum of arithmetics.

The Eratosthenes sieve algorithm trades space for speed. We write out
numbers on a piece of papyrus, starting from 2 till the desired upper
limit. We take the first number -- two in our case -- and hole out
every second number. We scan the piece for the next non-holed-out
number (which will be three) and hole out every third number, starting
from three. At the end, only the prime numbers will be left. The
Eratosthenes sieve, according to the above description, has an
imperative flavor. That is how it is often implemented [Note 1].
Nothing however prevents us from re-writing the algorithm in a pure
functional style, as the next section shows.

The Eratosthenes sieve algorithm can be used for testing if a number n
is prime. We build a list of numbers 2 through n and run the
algorithm. If the last number on the list is "holed out", n is
composite. Otherwise, it is prime.

* Pure-functional, generic implementation of the Eratosthenes sieve

First, we need to build a list of numbers 2 through n.

; Given a number 'n', build a list (2..n)
(define (iota n)
(letrec
((loop
(lambda (curr counter)
(if (less-than-two? counter) '()
(cons curr (loop (incr curr) (decr counter)))))))
(loop (number-two) n)))

Note how generic this function is: it deals with integers as an
abstract data type. We do not care how integers are actually
implemented.

; The sieve algorithm itself
; Given the list (2..n), return a sieved list
; all composite numbers are replaced by 0

(define (sieve lst)
(letrec
((choose-pivot ; choose the first non-zero element in lst
(lambda (lst)
(cond
((null? lst) lst)
((number-zero? (car lst)) ; skip over zeros
(cons (car lst) (choose-pivot (cdr lst))))
(else
(cons (car lst)          ; sieve with the pivot, and recurse
(choose-pivot
(do-sieve (car lst) (decr (car lst)) (cdr lst))))))))
; Run the sieve
; (do-sieve step current lst)
; Return the new lst with each step-th element sieved out:
; replaced by 0.
(do-sieve
(lambda (step current lst)
(cond
((null? lst) lst)
((number-zero? current)    ; replace the current element with zero
(cons (number-zero) (do-sieve step (decr step) (cdr lst))))
(else
(cons (car lst) (do-sieve step (decr current) (cdr lst)))))))
)
(choose-pivot lst)))

; Check if a given number is a prime: return 'prime or 'composite
; We run the sieve and then check if the last element has been weeded out

(define (is-prime n)
(if (number-zero? (car (reverse (sieve (iota n)))))
'composite
'prime))

To test these functions, we need to supply an implementation of
integers. First we use the most convenient representation:

(define (number-zero) 0)
(define (number-two) 2)
(define (incr n) (+ 1 n))
(define (decr n) (- n 1))
(define (less-than-two? n) (< n 2))
(define number-zero? zero?)

BTW, these are the only integer "methods" that we need to run
the Eratosthenes sieve. We don't even need general addition, subtraction,
or comparisons -- let alone multiplication or division.
Here are sample test cases and their output:

(display (iota 5))
;==> (2 3 4 5)
(display (sieve (iota 5)))
;==> (2 3 0 5)
(display (sieve (iota 25)))
;==> (2 3 0 5 0 7 0 0 0 11 0 13 0 0 0 17 0 19 0 0 0 23 0 0)
(display (is-prime 19)) ;==> prime
(display (is-prime 25)) ;==> composite

Next, we choose a Peano-Church representation of integers:

(define (number-zero) '() )
(define (number-two) '(( () )) )
(define (incr n) (list n))
(define (decr n) (car n))
(define (less-than-two? n) (or (null? n) (null? (car n))))
(define number-zero? null?)

The tests become

(display (iota '((((( () ))))) ))
;==> (((())) (((()))) ((((())))) (((((()))))))
(display (sieve (iota '((((( () ))))) )))
;==> (((())) (((()))) () (((((()))))))
(display (is-prime '((((((((((((((((((( () ))))))))))))))))))) ))
;==> prime
(display (is-prime '((((((((((((((((((((((((( () ))))))))))))))))))))))))) ))
;==> composite

Everything seems to work as expected.

* Compilation to syntax-rules.
Now, we can mechanically compile iota, sieve and is-prime
procedures to syntax-rule macros. First, however, we need to implement
the primitives number-zero, number-two, etc. as syntax-rule macros,
and add them to the initial environment of the compiler:

,(lambda (env)
(env-extend env 'incr '?incr
applies-directly: #t
cps-code:
'(define-syntax ?incr
(syntax-rules ()
((_ n k) (??!apply k  (n) ))))))

,(lambda (env)
(env-extend env 'decr '?decr
applies-directly: #t
cps-code:
'(define-syntax ?decr
(syntax-rules ()
((_ (n) k) (??!apply k  n ))))))

,(lambda (env)
(env-extend env 'less-than-two? '?less-than-two?
applies-directly: #t
if-fork: 'ifless-than-two?
cps-code:
'(define-syntax ?less-than-two?
(syntax-rules ()
((_ ((n)) k) (??!apply k #f))
((_ x k)  (??!apply k #t))))))

etc.

Now, we can just run the compiler:

(define test-Eratosthenes
'(
(define (iota n)
; exactly as above
)
(define (sieve lst)
; exactly as above
)
(define (is-prime n) ; exactly as above
(if (number-zero? (car (reverse (sieve (iota n)))))
'composite
'prime))
(define (reverse lst)
(letrec ((loop
(lambda (lst accum)
(if (null? lst) accum
(loop (cdr lst) (cons (car lst) accum))))))
(loop lst '())))
))

(write-out init-env test-Eratosthenes
; a test case
'(?iota ((((((( () )))))))
(??!lambda (x) (?sieve (??! x)
(??!lambda (x) (display '(??! x))))))
)

See the full code at
http://www.*-*-*.com/ ~oleg/ftp/Scheme/cps-macro-conv.scm

The compilation produces a file "/tmp/a.scm". We can interpret the
compiled code:
~> bigloo -i -hygien /tmp/a.scm
which prints the result:
(((())) (((()))) () (((((()))))) () (((((((()))))))))
If we macroexpaned the code, e.g.,
~> bigloo -hygien -syntax /tmp/a.scm
we would see that this result is indeed computed at macro-expand time.

I do not dare to show the compilation result. Ok, I will, but only a
little:

(define-syntax
?is-prime
(syntax-rules
()
((_ _?n _?kg1074)
(?iota _?n
(??!lambda
(g1081)
(?sieve
(??! g1081)
(??!lambda
(g1080)
(?reverse
(??! g1080)
(??!lambda
(g1079)
(?car (??! g1079)
(??!lambda
(g1078)
(?number-zero?
(??! g1078)
(??!lambda
(g1075)
(?iftrue?
(??! g1075)
(??!lambda
(g1076)
(??!apply _?kg1074 composite))
(??!lambda
(g1077)
(??!apply
_?kg1074
prime))))))))))))))))

(define-syntax
?iota
(syntax-rules
()
((_ _?n _?kg1029)
(letrec-syntax
((?loop (syntax-rules
()
((_ _?currg1031 _?counterg1032 _?kg1030)
(?ifless-than-two?
_?counterg1032
(??!lambda (g1033) (??!apply _?kg1030 ()))
(??!lambda
(g1034)
(?incr _?currg1031
(??!lambda
(g1036)
(?decr _?counterg1032
(??!lambda
(g1037)
(?loop (??! g1036)
(??! g1037)
(??!lambda
(g1035)
(?cons _?currg1031
(??! g1035)
_?kg1030)))))))))))))
(?number-two
(??!lambda
(g1038)
(?loop (??!
...

Sat, 01 Jan 2005 11:25:51 GMT  Scheme->syntax-rules [Was: hygienic macro primality tester]

Quote:

> A more systematic way of writing syntax-rules macros is to
> mechanically convert the corresponding Scheme procedures.  This
> approach also helps Joe Marshall, who wrote "I'm in need of an
> INTERCAL compiler written in SYNTAX-RULES"  Well, he can just compile
> the existing INTERCAL compiler to syntax-rules.

In the future I'll try to be more careful about what I wish for.

Sat, 01 Jan 2005 23:50:37 GMT  Scheme->syntax-rules [Was: hygienic macro primality tester]

Quote:

> ... a Scheme--to--syntax-rules compiler ... This approach also helps
> Joe Marshall, who wrote "I'm in need of an INTERCAL compiler written
> in SYNTAX-RULES" Well, he can just compile the existing INTERCAL
> compiler to syntax-rules.

Is there really an existing INTERCAL compiler written in scheme?

Below is an interpreter, written in a couple dozen lines of
syntax-rules code, for a language with a Forth-like pair of stacks,
one for data and one for control.  It is used to implement a complete
factorization:

(factor (1 0 0 2))
==expands to==>
'(= (1 0 0 2) (* (2) (3) (1 6 7)))   ;; i.e. (= 1002 (* 2 3 167))

You can operate in bases other than 10 by changing the list of digits
in the code.

Also included is a self-contained 45-line expression (a variant of
which I have posted before) that uses syntax-rules to compute 20!.  It
uses a simpler one-stack machine.  It works fine on systems like
bigloo that don't have bignums, because it contains its own bignum
implementation.

The bignum implementations in these two programs have the
computational complexity you would expect of bignums: multiplication
and division run in O(len^2) time, where len is the total length of
the inputs (i.e. the log of the product or dividend).

Quote:
> We must emphasize however the speed of developing the macros. We do
> all the development and testing with regular Scheme procedures. Once
> we have done all that, the translated syntax-rules macros _just
> work_. There is no need for macrology any more.

You mean you've invented a macros-written-in-scheme system to replace
the macros-written-in-syntax-rules system, and this allows us to lay
the field of macrology to rest?  I thought we had
macros-written-in-scheme systems twenty years ago.

-al

;; Here's the expression for 20!, which uses a single stack.
(letrec-syntax
((letrec-single-stack-macros
(syntax-rules ()
((_  ((kw                  ((subp ...    ) (subt ...    )) ... ) ...)
. body)
(letrec-syntax
((kw (syntax-rules () ((subp ... . s) (subt ... . s)) ...)) ...)
. body))))
(with-digits
(syntax-rules ()
((with-digits radix-1 (digit ...          ) (digit-1 ...        ))
(letrec-single-stack-macros
((ret ((_ result next-macro) (next-macro result)))
(snoc ((_ x y) (ret (y . x))))
(inc
((_ ()) (ret (1)))
((_ (radix-1 . x)) (inc x snoc 0))
((_ (digit-1 . x)) (ret (digit . x)))
...)
(dec
((_ (1)) (ret ()))
((_ (0 . x)) (dec x snoc radix-1))
((_ (digit . x)) (ret (digit-1 . x)))
...)
((_ x ()) (ret x))
((_ () x) (ret x))
((_ x (y1)) (dec (y1) add x inc))
((_ (x1 . x) (0  . y)) (add x y snoc x1))
((_ (x1 . x) (y1 . y)) (add x y snoc x1 add (y1))))
(multiply
((_ x ()) (ret ()))
((_ x (0 . y)) (multiply x y snoc 0))
((_ x y) (dec y multiply x add x)))
(factorial
((_ ()) (ret (1)))
((_ x) (dec x factorial multiply x)))
(reverse ((_ x) (rev2 x ())))
(rev2
((_ () acc) (ret acc))
((_ (x . y) acc) (rev2 y (x . acc)))))
(reverse (2 0) factorial reverse quote))))))
(with-digits (9 8 7 6 5 4 3 2 1 0)))

;; The two-stack machine processes commands off the execution stack
;; until it is empty, and then uses whatever remains on the data-stack
;; as its final expansion.  A command is one of:
;;    'datum               pushes datum onto the data stack
;;    function-name        passes the stacks to the named function,
;;       which should be a macro declared by letrec-stack-machine.
;;       These macros have rules that expand into a call back to
;;       run-stack-machine, with some number of items removed from the
;;       data-stack and transformed into some (possibly different) number
;;       of items added to the execution stack.
;;    (begin command ...)  executes command ... in order.
(define-syntax run-stack-machine
(syntax-rules (quote begin)
((_                      data-stack  ('x                  . exec-stack))
(run-stack-machine (x . data-stack)                        exec-stack ))
((_                      data-stack  ((begin command ...) . exec-stack))
(run-stack-machine      data-stack  (       command ...  . exec-stack)))
((_                      data-stack  (function-name       . exec-stack))
(function-name          data-stack                         exec-stack ))
((_                      data-stack  (                                 ))
data-stack)))

(define-syntax letrec-stack-machine
(syntax-rules ()
((_ literals
((function-name
((_           arg ...                                         )
command ...               )
...)
...)
. body-commands)
(letrec-syntax
((function-name
(syntax-rules literals
((_          (arg ... . data-stack)                exec-stack )
(run-stack-machine     data-stack  (command ... . exec-stack)))
...))
...)
(run-stack-machine () body-commands)))))

(define-syntax factor
(syntax-rules ()
((_      num)
(factor num
;; Choose a default set of digits.  For binary, use: (() 1 0)
;; For hex, use: ((f e d c b a) 9 8 7 6 5 4 3 2 1 0)
(() 9 8 7 6 5 4 3 2 1 0)))
((_      num ((id-digit ...) number-digit ...)               )
(factor num ( id-digit ...  number-digit ...) (id-digit ...)))
((_      num radix-1 (digit ...          ) (digit-1 ...        ) ids)
;; Internally, numbers are unsigned little-endian lists of
;; digits, with no trailing zeros.  Zero is therefore ().
;; Negative numbers underflow to #f.
(letrec-stack-machine ids
((dup ((_ x) 'x 'x))
(pop ((_ x)))
;; Note that when you call a function by executing
;; 'arg1 'arg2 'arg3 func, the top of the stack has arg3
;; when func is invoked.  That's why the patterns for
;; multivalued functions look like (_ arg3 arg2 arg1).
(exch ((_ y x) 'y 'x)) ; so yes, this rule exchanges x and y.
(if
((_ alternate consequent #f) alternate)
((_ alternate consequent truish) consequent))
(cons ((_ y x) '(x . y)))
(snoc ((_) exch cons))
(map
((_ func ()) '())
((_ func (x . y)) 'y 'func map 'x func snoc))
(zero?        ((_ ()) '#t) ((_ x) '#f))
(underflowed? ((_ #f) '#t) ((_ x) '#f))
(inc
((_ ()) '(1))
((_ (radix-1 . x)) 'x inc '0 snoc)
((_ (digit-1 . x)) '(digit . x))
...)
(dec
((_ ()) '#f)
((_ (1)) '())
((_ (0 . x)) 'x dec 'radix-1 snoc)
((_ (digit . x)) '(digit-1 . x))
...)
;; x y1 shift-in => 10*x+y1
;; y1 is a single digit, x is a number, possibly underflowed.
(shift-in
((_ y1 #f) '#f)
((_ 0 ()) '())
((_ y1 x) '(y1 . x)))
(-
((_ () x) 'x)
((_ y ()) '#f)
((_ y #f) '#f)
((_ (y1) x) 'x dec '(y1) dec -)
((_ (0  . y) (x1 . x)) 'x 'y - 'x1 shift-in)
((_ (y1 . y) (x1 . x)) 'x 'y - 'x1 shift-in '(y1) -))
;; < just leaves its args on the stack and calls - to subtract them.
(< ((_) - underflowed?))
;; div returns the quotient and the remainder (with the
;; remainder at the top of the stack).
(div
((_ divisor ()) '() '())
((_ divisor (dd1 . dividend))
'dividend 'divisor div      ; divide with smaller dividend.
exch '0 shift-in exch       ; adjust quotient.
'divisor fix-remainder)) ; do subtractions if remainder > divisor.
(fix-remainder
((_ divisor remainder quotient)
'remainder 'divisor -
dup underflowed?
'(begin pop 'quotient 'remainder)
'(begin 'quotient inc exch 'divisor fix-remainder)
if))
(reverse ((_ x) '() 'x rev2))
(rev2
((_ (x . y) acc) '(x . acc) 'y rev2)
((_ () acc) 'acc))
;; factor returns a list of the factors of n that are >= divisor.
(factor
((_ divisor n)
'n 'divisor div zero? ; divide and check for zero remainder.
'(begin 'divisor factor 'divisor snoc)
'(begin 'divisor <
;; if quotient < divisor, we've passed sqrt(n).
;; Return singleton n, unless n is one.
'(begin 'n dec zero? ''() ''(n) if)
'(begin 'n 'divisor inc factor)
if)
if)))
'num reverse '(1) inc factor
;; Convert factors to big-endian, and format output for display.
'reverse map '* snoc '() cons 'num snoc '= snoc 'quote))))

Sun, 02 Jan 2005 09:08:34 GMT  Scheme->syntax-rules [Was: hygienic macro primality tester]

[...]

Quote:
> We must emphasize however the speed of developing the macros. We do all
> the development and testing with regular Scheme procedures. Once we have
> done all that, the translated syntax-rules macros _just work_. There is
> no need for macrology any more.

Well, my hat's off to you.  Now if only people weren't so squeamish about
running real Scheme in compilation environments (completely disjoint from
the run-time environment, of course) I'd say we've accomplished
something.

-John

Sun, 02 Jan 2005 10:25:41 GMT  Scheme->syntax-rules [Was: hygienic macro primality tester]

Quote:

> ... a Scheme--to--syntax-rules compiler ... This approach also helps
> Joe Marshall, who wrote "I'm in need of an INTERCAL compiler written
> in SYNTAX-RULES" Well, he can just compile the existing INTERCAL
> compiler to syntax-rules.

Quote:
> Is there really an existing INTERCAL compiler written in scheme?

Well, Scheme is notorious for inducing partial evaluators, so an INTERCAL
interpreter schould suffice.

In fact, in this way the whole project seems a nice one to go through with
students: quite a bit of interesting theory is encountered along the way.

--
Biep