diff options
Diffstat (limited to 'mbe.scm')
| -rw-r--r-- | mbe.scm | 402 |
1 files changed, 207 insertions, 195 deletions
@@ -1,5 +1,5 @@ -;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, r4rs) -;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, revised Sept. 3, 1992, +;;;; "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 @@ -17,89 +17,192 @@ ;promotional, or sales literature without prior written consent in ;each case. -;;; revised Dec. 6, 1993 to r4rs syntax (if not semantics). +;;; 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 Macro-by-Example (Eugene -;;; Kohlbecker, r4rs). This file requires defmacro. +;;; 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) -;;; A vanilla implementation of a hygiene filter for define-syntax +(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-generic -; (lambda (e kk tmps) e)) +(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))))) -;;; if you don't want the hygiene filter, comment out the following -;;; s-exp and uncomment the previous one. +;;untagging -(define hyg:tag-generic - (lambda (e kk tmps) +(define hyg:untag + (lambda (e al tmps) (if (pair? e) - (let ((a (car e))) - (case a - ((quote) `(quote ,(hyg:tag-vanilla (cadr e) kk tmps))) - ((if begin) - `(,a ,@(map (lambda (e1) (hyg:tag-generic e1 kk tmps)) - (cdr e)))) - ((set! define) - `(,a ,(hyg:tag-vanilla (cadr e) kk tmps) - ,@(map (lambda (e1) (hyg:tag-generic e1 kk tmps)) - (cddr e)))) - ((lambda) (hyg:tag-lambda (cdr e) kk tmps)) - ((letrec) (hyg:tag-letrec (cdr e) kk tmps)) - ((let) (hyg:tag-let (cdr e) kk tmps)) - ((let*) (hyg:tag-let-star (cdr e) kk tmps)) - ((do) (hyg:tag-do (cdr e) kk tmps)) - ((case) - `(case ,(hyg:tag-generic (cadr e) kk tmps) - ,@(map - (lambda (cl) - `(,(hyg:tag-vanilla (car cl) kk tmps) - ,@(map - (lambda (e1) - (hyg:tag-generic e1 kk tmps)) - (cdr cl)))) - (cddr e)))) - ((cond) - `(cond ,@(map - (lambda (cl) - (map (lambda (e1) - (hyg:tag-generic e1 kk tmps)) - cl)) - (cdr e)))) - (else (map (lambda (e1) - (hyg:tag-generic e1 kk tmps)) - e)))) - (hyg:tag-vanilla e kk tmps)))) + (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:tag-vanilla - (lambda (e kk tmps) - (cond ((symbol? e) - (cond ((memq e kk) e) - ((assq e tmps) => cdr) - (else e))) - ((pair? e) - (cons (hyg:tag-vanilla (car e) kk tmps) - (hyg:tag-vanilla (cdr e) kk tmps))) - (else e)))) +(define hyg:untag-list + (lambda (ee al tmps) + (map (lambda (e) + (hyg:untag e al tmps)) ee))) -(define hyg:tag-lambda - (lambda (e kk tmps) - (let* ((bvv (car e)) - (tmps2 (append - (map (lambda (v) (cons v (gentemp))) - (hyg:flatten bvv)) - tmps))) - `(lambda - ,(hyg:tag-vanilla bvv kk tmps2) - ,@(map - (lambda (e1) - (hyg:tag-generic e1 kk tmps2)) - (cdr e)))))) +(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) @@ -109,100 +212,6 @@ ((null? e) r) (else (cons e r)))))) -(define hyg:tag-letrec - (lambda (e kk tmps) - (let* ((varvals (car e)) - (tmps2 (append - (map (lambda (v) (cons v (gentemp))) - (map car varvals)) - tmps))) - `(letrec ,(map - (lambda (varval) - `(,(hyg:tag-vanilla (car varval) - kk tmps2) - ,(hyg:tag-generic (cadr varval) - kk tmps2))) - varvals) - ,@(map (lambda (e1) - (hyg:tag-generic e1 kk tmps2)) - (cdr e)))))) - -(define hyg:tag-let - (lambda (e kk tmps) - (let* ((tt (if (symbol? (car e)) (cons (car e) (gentemp)) '())) - (e (if (null? tt) e (cdr e))) - (tmps (if (null? tt) tmps (append (list tt) tmps)))) - (let* ((varvals (car e)) - (tmps2 (append (map (lambda (v) (cons v (gentemp))) - (map car varvals)) - tmps))) - `(let - ,@(if (null? tt) '() `(,(hyg:tag-vanilla (car tt) - kk - tmps))) - ,(let loop ((varvals varvals) - (i (length varvals))) - (if (null? varvals) '() - (let ((varval (car varvals)) - (tmps3 (list-tail tmps2 i))) - (cons `(,(hyg:tag-vanilla (car varval) - kk tmps2) - ,(hyg:tag-generic (cadr varval) - kk tmps3)) - (loop (cdr varvals) (- i 1)))))) - ,@(map - (lambda (e1) - (hyg:tag-generic e1 kk tmps2)) - (cdr e))))))) - -(define hyg:tag-do - (lambda (e kk tmps) - (let* ((varinistps (car e)) - (tmps2 (append (map (lambda (v) (cons v (gentemp))) - (map car varinistps)) - tmps))) - `(do - ,(let loop ((varinistps varinistps) - (i (length varinistps))) - (if (null? varinistps) '() - (let ((varinistp (car varinistps)) - (tmps3 (list-tail tmps2 i))) - (cons `(,(hyg:tag-vanilla (car varinistp) - kk tmps2) - ,(hyg:tag-generic (cadr varinistp) - kk tmps3) - ,@(hyg:tag-generic (cddr varinistp) - kk tmps2)) - (loop (cdr varinistps) (- i 1)))))) - ,(map (lambda (e1) - (hyg:tag-generic e1 kk tmps2)) (cadr e)) - ,@(map - (lambda (e1) - (hyg:tag-generic e1 kk tmps2)) - (cddr e)))))) - -(define hyg:tag-let-star - (lambda (e kk tmps) - (let* ((varvals (car e)) - (tmps2 (append (reverse (map (lambda (v) (cons v (gentemp))) - (map car varvals))) - tmps))) - `(let* - ,(let loop ((varvals varvals) - (i (- (length varvals) 1))) - (if (null? varvals) '() - (let ((varval (car varvals)) - (tmps3 (list-tail tmps2 i))) - (cons `(,(hyg:tag-vanilla (car varval) - kk tmps3) - ,(hyg:tag-generic (cadr varval) - kk (cdr tmps3))) - (loop (cdr varvals) (- i 1)))))) - ,@(map - (lambda (e1) - (hyg:tag-generic e1 kk tmps2)) - (cdr e)))))) - ;;;; End of hygiene filter. ;;; finds the leftmost index of list l where something equal to x @@ -226,7 +235,7 @@ (and e-head=e-tail (let ((e-head (car e-head=e-tail)) (e-tail (cdr e-head=e-tail))) - (and (comlist:every + (and (every (lambda (x) (mbe:matches-pattern? p-head x k)) e-head) (mbe:matches-pattern? p-tail e-tail k))))))) @@ -294,7 +303,7 @@ ;;; variables in nestings (define mbe:ellipsis-sub-envs (lambda (nestings r) - (comlist:some (lambda (c) + (some (lambda (c) (if (mbe:contained-in? nestings (car c)) (cdr c) #f)) r))) @@ -302,8 +311,8 @@ (define mbe:contained-in? (lambda (v y) (if (or (symbol? v) (symbol? y)) (eq? v y) - (comlist:some (lambda (v_i) - (comlist:some (lambda (y_j) + (some (lambda (v_i) + (some (lambda (y_j) (mbe:contained-in? v_i y_j)) y)) v)))) @@ -328,33 +337,36 @@ (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)) + (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) - (hyg:tag-generic - (mbe:expand-pattern - ',out-pattern - (mbe:get-bindings ',in-pattern macro-arg - keywords) - keywords) - (nconc - (hyg:flatten ',in-pattern) - keywords) - '())))) - clauses) - (else (slib:error ',macro-name 'no-matching-clause - ',clauses)))))))) + `((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) |