A simple implementation of the hygienic macro expander described in Macros-That-Work

macros_that_work.scm

;e;; A simple macro expander implementation based on Macros That Work.
;;; 

;;; Usage:
;;; (macroexpand s-exp) yields a fully expanded form
;;;
;;; Primitive special forms:
;;; if
;;; set!
;;; begin
;;; quote
;;; lambda
;;; 

;;;;;;;;;       denotation environment
;; global variable denotation: identifier
;; local variable denotation:  (original-name . marked-name)
;; macro denotation:           (name . macro-transformer)

(define (extend-env vars dens env)
  (cond
   [(null? vars) env]
   [(pair? vars)
    (cons (cons (car vars) (car dens))
          (extend-env (cdr vars)
                      (cdr dens)
                      env))]
   [else
    (cons (cons vars dens)
          env)]))

(define (apply-env env name)
  (cond
    [(assq name env) => cdr]
    [else name]))

(define (identifier? den)
  (or (symbol? den)
      (symbol? (cdr den))))

(define (macro? den)
  (and (pair? den)
       (procedure? (cdr den))))

(define (make-denotation name value)
  (cons name value))

(define (denotation-name den)
  (if (pair? den)
      (car den)
      den))

(define (denotation-value den)
  (if (pair? den)
      (cdr den)
      den))

(define (invoke-macro den e env)
  ((denotation-value den) e env))

;;;;;;;;;;  marking (renaming)

(define new-mark #f)

(define (init-mark!)
  (set! new-mark
    (let ([i 0])
      (lambda ()
        (set! i (+ i 1))
        i))))

(define (mark-identifier name mark)
  (string->symbol
   (string-append
    (symbol->string name)
    "."
    (number->string mark))))

(define (unmark e env)
  (cond
    [(symbol? e)
     (denotation-name (apply-env env e))]
    [(pair? e)
     (cons (unmark (car e) env)
           (unmark (cdr e) env))]
    [else e]))

;;;;;;;;;  helper functions

;; works for both lists and dotted lists
(define (map1* f ls)
  (cond
    [(null? ls) '()]
    [(pair? ls) (cons (f (car ls))
                      (map1* f (cdr ls)))]
    [else       (f ls)]))

(define (map* f . lss)
  (cond
   [(null? (car lss)) '()]
   [(pair? (car lss))
    (cons (apply f (map1* car lss))
          (apply map* f (map1* cdr lss)))]
   [else
    (apply f lss)]))

;;;;;;;;;; macro expander

(define (macroexpand e)
  (init-mark!)
  (let expand ([e e] [env '()])
    (cond
     [(symbol? e)
      (let ([den (apply-env env e)])
        (if (macro? den)
            (error 'macroexpand "Invalid syntax" e)
            (denotation-value den)))]
     [(pair? e)
      (let ([den (apply-env env (car e))])
        (case (denotation-value den)
          [(if)
           `(if ,(expand (cadr e) env)
                ,(expand (caddr e) env)
                ,(expand (cadddr e) env))]
          [(set!)
           `(set! ,(expand (cadr e) env)
              ,(expand (caddr e) env))]
          [(quote)
           `(quote ,(unmark (cadr e) env))]
          [(begin)
           `(begin . ,(map (lambda (e)
                             (expand e env))
                           env))]
          [(lambda)
           (let* ([mark     (new-mark)]
                  [vars     (cadr e)]
                  [new-vars (map1* (lambda (name)
                                     (mark-identifier
                                      ;; a lambda may be introduced by a macro,
                                      ;; of which the formal arguments are marked.
                                      ;; We need to unmark them first.
                                      (unmark name env)
                                      mark))
                                   vars)]
                  [env      (extend-env vars
                                        (map* make-denotation vars new-vars)
                                        env)])
             `(lambda ,new-vars
                . ,(map (lambda (e)
                          (expand e env))
                        (cddr e))))]
          [(syntax-rules)
           (error 'macroexpand "Misplaced syntax-rules")]
          [(let-syntax)
           (let ([env (extend-env
                       (map car (cadr e))
                       (map (lambda (p)
                              (make-denotation
                               (car p)
                               (make-macro-transformer (cadr p) env)))
                            (cadr e))
                       env)])
             `(begin
                . ,(map (lambda (x)
                          (expand x env))
                        (cddr e))))]
          [else
           (if (macro? den)
               (let-values ([(e env)
                             (invoke-macro den e env)])
                 (expand e env))
               (map (lambda (e)
                      (expand e env))
                    e))]))]
     [else e])))

;;;;;;;;;;   macro transformer

(define (make-macro-transformer e def-env)
  (if (eq? 'syntax-rules
           (denotation-value
            (apply-env def-env (car e))))
      (let ([literals (cadr e)]
            [rules    (cddr e)])
        (lambda (e use-env)
          (let loop ([rules rules])
            (if (null? rules)
                (error 'macroexpand "Invalid syntax" e)
                (let ([pattern  (caar rules)]
                      [template (cadar rules)])
                  (let ([bindings (match e pattern literals use-env def-env)])
                    (if bindings
                        (transcribe template bindings use-env def-env)
                        (loop (cdr rules)))))))))
      (error 'macroexpand "Invalid macro transformer")))

(define (match e pattern literals use-env def-env)
  (call/cc
   (lambda (fail)
     (let rec ([e (cdr e)] [pattern (cdr pattern)])
       (cond
         [(symbol? pattern)
          (if (memq pattern literals)
              (if (eq? (apply-env use-env e)
                       (apply-env def-env pattern))
                  '()
                  (fail #f))
              (list (cons pattern e)))]
         [(pair? pattern)
          (if (pair? e)
              (append (rec (car e) (car pattern))
                      (rec (cdr e) (cdr pattern)))
              (fail #f))]
         [else
          (if (eqv? e pattern)
              '()
              (fail #f))])))))

(define (transcribe template bindings use-env def-env)
  (letrec ([mark (new-mark)]
           [rec (lambda (template)
                  (cond
                    [(symbol? template)
                     (cond
                      [(assq template bindings) => cdr]
                      [else
                       (let ([new-id (mark-identifier template mark)])
                         (set! use-env
                            (extend-env new-id
                                        (apply-env def-env template)
                                        use-env))
                         new-id)])]
                    [(pair? template)
                     (cons (rec (car template))
                           (rec (cdr template)))]
                    [else template]))])
    (let ([e1 (rec template)])
      (values e1 use-env))))


;;;;;;;;;;;;;;;; test

(define-syntax test
  (syntax-rules ()
    [(_ e res)
     (let ([ret (macroexpand 'e)])
       (if (not (equal? ret 'res))
           (error 'test "test failed" 'e 'res)))]))

(test (lambda (x y)
        (cons y
              (lambda y
                (if (> y x)
                    (set! z (+ x y))
                    '(x y z 10)))))
      (lambda (x.1 y.1)
        (cons y.1
              (lambda y.2
                (if (> y.2 x.1)
                    (set! z (+ x.1 y.2))
                    '(x y z 10))))))

(test (let-syntax
        ([foo (syntax-rules ()
                [(_ (x) y)  (x (y x))])])
        (foo (1) 2))
      (begin
        (1 (2 1))))

(test (let-syntax
        ([foo (syntax-rules (xx)
                [(_ xx a)
                 (lambda (t1 t2)
                   t1
                   '(xx (yy a)))]
                [(_ y a)
                 (a y x)])])
        ((foo xx 123)
         (lambda (xx x)
           (foo xx x))))
      (begin
        ((lambda (t1.2 t2.2)
           t1.2
           '(xx (yy 123)))
         (lambda (xx.3 x.3)
           (x.3 xx.3 x)))))

(test (lambda (x)
        (let-syntax
          ([foo (syntax-rules ()
                  [(_ y) (x y)])])
          ((foo x)
           (lambda (x)
             (foo x)))))
      (lambda (x.1)
        (begin
          ((x.1 x.1)
           (lambda (x.3)
             (x.1 x.3))))))