;;;; "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. ;;; A vanilla implementation of hygienic macro-by-example as described ;;; by Eugene Kohlbecker and in R4RS Appendix. This file requires ;;; defmacro. (require 'common-list-functions) ;nconc, some, every ;(require 'rev2-procedures) ;append! alternate for nconc (require 'rev4-optional-procedures) ;list-tail (require 'defmacroexpand) (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 (gentemp))) (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 (nconc (hyg:flatten bvv) tmps))) `(lambda ,bvv ,@(hyg:untag-list body al tmps2))))) (define hyg:untag-letrec (lambda (varvals body al tmps) (let ((tmps (nconc (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 (nconc (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 (nconc (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 (nconc (nreverse (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 (nconc (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)) (slib: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 (defmacro define-syntax (macro-name syn-rules) (if (or (not (pair? syn-rules)) (not (eq? (car syn-rules) 'syntax-rules))) (slib:error 'define-syntax 'not-an-r4rs-high-level-macro macro-name syn-rules) (let ((keywords (cons macro-name (cadr syn-rules))) (clauses (cddr syn-rules))) `(defmacro ,macro-name macro-arg (let ((macro-arg (cons ',macro-name macro-arg)) (keywords ',keywords)) (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 (nconc (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 (slib:error ',macro-name 'no-matching-clause ',clauses)))))))) (define macro:eval slib:eval) (define macro:load slib:load) (provide 'macro) ;eof