Implicit Renaming Macros for Chibi Scheme

ir-macros.scm

;; Implicit renaming macros a la Chicken Scheme
;; Tested on Chibi Scheme 0.5.3
;;

;; Like assq, but returns the entry based on the cdr rather than the car
(define (rassq obj alist)
  (let loop ((as alist))
    (if (null? as)
      #f
      (if (eq? (cdr (car as)) obj)
        (car as)
        (loop (cdr as))))))

;; Like map, but also handle improper lists and vectors
(define (imp-map f lst)
  (cond ((list? lst) (map f lst))
        ((vector? lst) (list->vector (map f (vector->list lst))))
        ((pair? lst)
         (if (pair? (cdr lst))
           (cons (f (car lst)) (imp-map f (cdr lst)))
           (cons (f (car lst)) (f (cdr lst)))))
        (else (error "imp-map"))))

;; Like imp-map, but descends into nested lists/vectors
(define (imp-walk f lst)
  (imp-map (lambda (x)
             (if (or (pair?   x)
                     (vector? x))
               (imp-walk f x)
               (f x)))
           lst))

;; Like er-macro-transformer, but hygiene is the default (based on the
;; transformer with the same name in Chicken Scheme, derived from Chibi's
;; er-macro-transformer code in init-7.scm)
(define ir-macro-transformer
  (lambda (f)
    (lambda (expr use-env mac-env)
      (define renames '())          ;; alist of (symbol . alias)
      
      (define (rename identifier)
        (if (symbol? identifier)
          (let ((cell (assq identifier renames)))
            (if cell
              (cdr cell)
              (let ((name (make-syntactic-closure mac-env '() identifier)))
                (set! renames (cons (cons identifier name) renames))
                name)))
          identifier))
      
      (define (compare x y)
        (identifier=? use-env x use-env y))
      
      (define (renamed? identifier)
        (rassq identifier renames))
      
      (define (inject identifier)
        (let ((cell (rassq identifier renames)))
           (if cell
             (car cell)
             identifier)))
      
      ;; This is the meat.  Rename all the inputs, call the transformer
      ;; function, then "flip" the renamedness of the outputs (i.e., if
      ;; a symbol is renamed, unrename it; otherwise rename it.)
      (let* ((expr (imp-walk rename expr))
             (res  (f expr rename compare)))
        (imp-walk (lambda (x)
                    (if (renamed? x)
                      (inject x)
                      (rename x)))
                  res)))))

;; Lemma-style, intuitive hygienic defmacro (which itself isn't hygienic...)
;; (proof of concept)
(define-syntax defmacro
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((keyword (cadr form))
            (names   (caddr form))
            (body    (cdddr form)))
        `(define-syntax ,keyword
           (ir-macro-transformer
             (lambda (form ,(inject 'inject) ,(inject 'compare?))
               (apply (lambda ,names ,@body) (cdr form)))))))))

;; Same as above, but with more Schemey syntax
(define-syntax define-macro
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((keyword (car (cadr form)))
            (names   (cdr (cadr form)))
            (body    (cddr form)))
        `(define-syntax ,keyword
           (ir-macro-transformer
             (lambda (form ,(inject 'inject) ,(inject 'compare?))
               (apply (lambda ,names ,@body) (cdr form)))))))))