;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, R4RS)
;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, 1997
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; revised Dec. 6, 1993 to R4RS syntax (if not semantics).
;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu).
;;; corrections, Apr. 24, 1997.
;;; revised Aug. 30 1999 for STk (eg@unice.fr)
;;;
;;; Last file update: 31-Aug-1999 15:56 (eg)
;;;
;;; A vanilla implementation of hygienic macro-by-example as described
;;; by Eugene Kohlbecker and in R4RS Appendix.
(define-module MBE
;;;
;;; Scheme utilities
;;;
(define (reverse! l)
(let loop ((l l) (r '()))
(if (null? l)
r
(let ((d (cdr l)))
(set-cdr! l r)
(loop d l)))))
;=============================================================================
(define hyg:rassq
(lambda (k al)
(let loop ((al al))
(if (null? al) #f
(let ((c (car al)))
(if (eq? (cdr c) k) c
(loop (cdr al))))))))
(define hyg:tag
(lambda (e kk al)
(cond ((pair? e)
(let* ((a-te-al (hyg:tag (car e) kk al))
(d-te-al (hyg:tag (cdr e) kk (cdr a-te-al))))
(cons (cons (car a-te-al) (car d-te-al))
(cdr d-te-al))))
((vector? e)
(list->vector
(hyg:tag (vector->list e) kk al)))
((symbol? e)
(cond ((eq? e '...) (cons '... al))
((memq e kk) (cons e al))
((hyg:rassq e al) =>
(lambda (c)
(cons (car c) al)))
(else
(let ((te (gensym)))
(cons te (cons (cons te e) al))))))
(else (cons e al)))))
;;untagging
(define hyg:untag
(lambda (e al tmps)
(if (pair? e)
(let ((a (hyg:untag (car e) al tmps)))
(if (list? e)
(case a
((quote) (hyg:untag-no-tags e al))
((if begin)
`(,a ,@(map (lambda (e1)
(hyg:untag e1 al tmps)) (cdr e))))
((set! define)
`(,a ,(hyg:untag-vanilla (cadr e) al tmps)
,@(map (lambda (e1)
(hyg:untag e1 al tmps)) (cddr e))))
((lambda) (hyg:untag-lambda (cadr e) (cddr e) al tmps))
((letrec) (hyg:untag-letrec (cadr e) (cddr e) al tmps))
((let)
(let ((e2 (cadr e)))
(if (symbol? e2)
(hyg:untag-named-let e2 (caddr e) (cdddr e) al tmps)
(hyg:untag-let e2 (cddr e) al tmps))))
((let*) (hyg:untag-let* (cadr e) (cddr e) al tmps))
((do) (hyg:untag-do (cadr e) (caddr e) (cdddr e) al tmps))
((case)
`(case ,(hyg:untag-vanilla (cadr e) al tmps)
,@(map
(lambda (c)
`(,(hyg:untag-vanilla (car c) al tmps)
,@(hyg:untag-list (cdr c) al tmps)))
(cddr e))))
((cond)
`(cond ,@(map
(lambda (c)
(hyg:untag-list c al tmps))
(cdr e))))
(else (cons a (hyg:untag-list (cdr e) al tmps))))
(cons a (hyg:untag-list* (cdr e) al tmps))))
(hyg:untag-vanilla e al tmps))))
(define hyg:untag-list
(lambda (ee al tmps)
(map (lambda (e)
(hyg:untag e al tmps)) ee)))
(define hyg:untag-list*
(lambda (ee al tmps)
(let loop ((ee ee))
(if (pair? ee)
(cons (hyg:untag (car ee) al tmps)
(loop (cdr ee)))
(hyg:untag ee al tmps)))))
(define hyg:untag-no-tags
(lambda (e al)
(cond ((pair? e)
(cons (hyg:untag-no-tags (car e) al)
(hyg:untag-no-tags (cdr e) al)))
((vector? e)
(list->vector
(hyg:untag-no-tags (vector->list e) al)))
((not (symbol? e)) e)
((assq e al) => cdr)
(else e))))
(define hyg:untag-lambda
(lambda (bvv body al tmps)
(let ((tmps2 (append! (hyg:flatten bvv) tmps)))
`(lambda ,bvv
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-letrec
(lambda (varvals body al tmps)
(let ((tmps (append! (map car varvals) tmps)))
`(letrec
,(map
(lambda (varval)
`(,(car varval)
,(hyg:untag (cadr varval) al tmps)))
varvals)
,@(hyg:untag-list body al tmps)))))
(define hyg:untag-let
(lambda (varvals body al tmps)
(let ((tmps2 (append! (map car varvals) tmps)))
`(let
,(map
(lambda (varval)
`(,(car varval)
,(hyg:untag (cadr varval) al tmps)))
varvals)
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-named-let
(lambda (lname varvals body al tmps)
(let ((tmps2 (cons lname (append! (map car varvals) tmps))))
`(let ,lname
,(map
(lambda (varval)
`(,(car varval)
,(hyg:untag (cadr varval) al tmps)))
varvals)
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-let*
(lambda (varvals body al tmps)
(let ((tmps2 (append! (reverse! (map car varvals)) tmps)))
`(let*
,(let loop ((varvals varvals)
(i (length varvals)))
(if (null? varvals) '()
(let ((varval (car varvals)))
(cons `(,(car varval)
,(hyg:untag (cadr varval)
al (list-tail tmps2 i)))
(loop (cdr varvals) (- i 1))))))
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-do
(lambda (varinistps exit-test body al tmps)
(let ((tmps2 (append! (map car varinistps) tmps)))
`(do
,(map
(lambda (varinistp)
(let ((var (car varinistp)))
`(,var ,@(hyg:untag-list (cdr varinistp) al
(cons var tmps)))))
varinistps)
,(hyg:untag-list exit-test al tmps2)
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-vanilla
(lambda (e al tmps)
(cond ((pair? e)
(cons (hyg:untag-vanilla (car e) al tmps)
(hyg:untag-vanilla (cdr e) al tmps)))
((vector? e)
(list->vector
(hyg:untag-vanilla (vector->list e) al tmps)))
((not (symbol? e)) e)
((memq e tmps) e)
((assq e al) => cdr)
(else e))))
(define hyg:flatten
(lambda (e)
(let loop ((e e) (r '()))
(cond ((pair? e) (loop (car e)
(loop (cdr e) r)))
((null? e) r)
(else (cons e r))))))
;;;; End of hygiene filter.
;;; finds the leftmost index of list l where something equal to x
;;; occurs
(define mbe:position
(lambda (x l)
(let loop ((l l) (i 0))
(cond ((not (pair? l)) #f)
((equal? (car l) x) i)
(else (loop (cdr l) (+ i 1)))))))
;;; tests if expression e matches pattern p where k is the list of
;;; keywords
(define mbe:matches-pattern?
(lambda (p e k)
(cond ((mbe:ellipsis? p)
(and (or (null? e) (pair? e))
(let* ((p-head (car p))
(p-tail (cddr p))
(e-head=e-tail (mbe:split-at-ellipsis e p-tail)))
(and e-head=e-tail
(let ((e-head (car e-head=e-tail))
(e-tail (cdr e-head=e-tail)))
(and (every
(lambda (x) (mbe:matches-pattern? p-head x k))
e-head)
(mbe:matches-pattern? p-tail e-tail k)))))))
((pair? p)
(and (pair? e)
(mbe:matches-pattern? (car p) (car e) k)
(mbe:matches-pattern? (cdr p) (cdr e) k)))
((symbol? p) (if (memq p k) (eq? p e) #t))
(else (equal? p e)))))
;;; gets the bindings of pattern variables of pattern p for
;;; expression e;
;;; k is the list of keywords
(define mbe:get-bindings
(lambda (p e k)
(cond ((mbe:ellipsis? p)
(let* ((p-head (car p))
(p-tail (cddr p))
(e-head=e-tail (mbe:split-at-ellipsis e p-tail))
(e-head (car e-head=e-tail))
(e-tail (cdr e-head=e-tail)))
(cons (cons (mbe:get-ellipsis-nestings p-head k)
(map (lambda (x) (mbe:get-bindings p-head x k))
e-head))
(mbe:get-bindings p-tail e-tail k))))
((pair? p)
(append (mbe:get-bindings (car p) (car e) k)
(mbe:get-bindings (cdr p) (cdr e) k)))
((symbol? p)
(if (memq p k) '() (list (cons p e))))
(else '()))))
;;; expands pattern p using environment r;
;;; k is the list of keywords
(define mbe:expand-pattern
(lambda (p r k)
(cond ((mbe:ellipsis? p)
(append (let* ((p-head (car p))
(nestings (mbe:get-ellipsis-nestings p-head k))
(rr (mbe:ellipsis-sub-envs nestings r)))
(map (lambda (r1)
(mbe:expand-pattern p-head (append r1 r) k))
rr))
(mbe:expand-pattern (cddr p) r k)))
((pair? p)
(cons (mbe:expand-pattern (car p) r k)
(mbe:expand-pattern (cdr p) r k)))
((symbol? p)
(if (memq p k) p
(let ((x (assq p r)))
(if x (cdr x) p))))
(else p))))
;;; returns a list that nests a pattern variable as deeply as it
;;; is ellipsed
(define mbe:get-ellipsis-nestings
(lambda (p k)
(let sub ((p p))
(cond ((mbe:ellipsis? p) (cons (sub (car p)) (sub (cddr p))))
((pair? p) (append (sub (car p)) (sub (cdr p))))
((symbol? p) (if (memq p k) '() (list p)))
(else '())))))
;;; finds the subenvironments in r corresponding to the ellipsed
;;; variables in nestings
(define mbe:ellipsis-sub-envs
(lambda (nestings r)
(some (lambda (c)
(if (mbe:contained-in? nestings (car c)) (cdr c) #f))
r)))
;;; checks if nestings v and y have an intersection
(define mbe:contained-in?
(lambda (v y)
(if (or (symbol? v) (symbol? y)) (eq? v y)
(some (lambda (v_i)
(some (lambda (y_j)
(mbe:contained-in? v_i y_j))
y))
v))))
;;; split expression e so that its second half matches with
;;; pattern p-tail
(define mbe:split-at-ellipsis
(lambda (e p-tail)
(if (null? p-tail) (cons e '())
(let ((i (mbe:position (car p-tail) e)))
(if i (cons (butlast e (- (length e) i))
(list-tail e i))
(error "mbe:split-at-ellipsis : bad-arg"))))))
;;; tests if x is an ellipsing pattern, i.e., of the form
;;; (blah ... . blah2)
(define mbe:ellipsis?
(lambda (x)
(and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...))))
;define-syntax
(define-macro (define-syntax macro-name syn-rules)
(if (or (not (pair? syn-rules))
(not (eq? (car syn-rules) 'syntax-rules)))
(error "define-syntax: in ~S, bad syntax-rules" macro-name syn-rules)
(let ((keywords (cons macro-name (cadr syn-rules)))
(clauses (cddr syn-rules)))
`(define-macro (,macro-name . macro-arg)
(let ((macro-arg (cons ',macro-name macro-arg))
(keywords ',keywords)
(mbe:matches-pattern? (with-module mbe mbe:matches-pattern?))
(mbe:expand-pattern (with-module mbe mbe:expand-pattern))
(mbe:get-bindings (with-module mbe mbe:get-bindings))
(hyg:tag (with-module mbe hyg:tag))
(hyg:untag (with-module mbe hyg:untag))
(hyg:flatten (with-module mbe hyg:flatten)))
(cond ,@(map
(lambda (clause)
(let ((in-pattern (car clause))
(out-pattern (cadr clause)))
`((mbe:matches-pattern? ',in-pattern macro-arg
keywords)
(let ((tagged-out-pattern+alist
(hyg:tag
',out-pattern
(append! (hyg:flatten ',in-pattern) keywords)
'())))
(hyg:untag
(mbe:expand-pattern
(car tagged-out-pattern+alist)
(mbe:get-bindings ',in-pattern macro-arg keywords)
keywords)
(cdr tagged-out-pattern+alist)
'())))))
clauses)
(else (error "~S: no matching clause: ~S"
',macro-name ',clauses))))))))
)
;; Make only define-syntax visible from MBE
(with-module Scheme
(define define-syntax (with-module MBE define-syntax)))
(provide "defsyntax")