diff options
Diffstat (limited to 'mbe.scm')
| -rw-r--r-- | mbe.scm | 323 |
1 files changed, 196 insertions, 127 deletions
@@ -1,5 +1,5 @@ ;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, R4RS) -;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, 1997 +;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, 1999 ; ;Permission to copy this software, to redistribute it, and to use it ;for any purpose is granted, subject to the following restrictions and @@ -20,6 +20,7 @@ ;;; revised Dec. 6, 1993 to R4RS syntax (if not semantics). ;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu). ;;; corrections, Apr. 24, 1997. +;;; corr., Jan. 30, 1999. (mflatt@cs.rice.edu, dorai@cs.rice.edu) ;;; A vanilla implementation of hygienic macro-by-example as described ;;; by Eugene Kohlbecker and in R4RS Appendix. This file requires @@ -34,29 +35,29 @@ (lambda (k al) (let loop ((al al)) (if (null? al) #f - (let ((c (car al))) - (if (eq? (cdr c) k) c - (loop (cdr al)))))))) + (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)))) + (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))) + (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)))))) + (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 @@ -65,140 +66,184 @@ (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)))) + (if (list? e) + (case a + ((quote) (hyg:untag-no-tags e al)) + ((quasiquote) (list a (hyg:untag-quasiquote (cadr e) al tmps))) + ((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))) + (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))))) + (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))) + (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))) + (list->vector + (hyg:untag-no-tags (vector->list e) al))) ((not (symbol? e)) e) ((assq e al) => cdr) (else e)))) +(define hyg:untag-quasiquote + (lambda (form al tmps) + (let qq ((x form) (level 0)) + (cond + ((pair? x) + (let ((first (qq (car x) level))) + (cond + ((and (eq? first 'unquote) (list? x)) + (let ((rest (cdr x))) + (if (or (not (pair? rest)) + (not (null? (cdr rest)))) + (slib:error 'unquote 'takes-exactly-one-expression) + (if (zero? level) + (list 'unquote (hyg:untag (car rest) al tmps)) + (cons first (qq rest (sub1 level))))))) + ((and (eq? first 'quasiquote) (list? x)) + (cons 'quasiquote (qq (cdr x) (add1 level)))) + ((and (eq? first 'unquote-splicing) (list? x)) + (slib:error 'unquote-splicing 'invalid-context-within-quasiquote)) + ((pair? first) + (let ((car-first (qq (car first) level))) + (if (and (eq? car-first 'unquote-splicing) + (list? first)) + (let ((rest (cdr first))) + (if (or (not (pair? rest)) + (not (null? (cdr rest)))) + (slib:error 'unquote-splicing + 'takes-exactly-one-expression) + (list (list 'unquote-splicing + (if (zero? level) + (hyg:untag (cadr rest) al tmps) + (qq (cadr rest) (sub1 level))) + (qq (cdr x) level))))) + (cons (cons car-first + (qq (cdr first) level)) + (qq (cdr x) level))))) + (else + (cons first (qq (cdr x) level)))))) + ((vector? x) + (list->vector + (qq (vector->list x) level))) + (else (hyg:untag-no-tags x al)))))) + (define hyg:untag-lambda (lambda (bvv body al tmps) (let ((tmps2 (nconc (hyg:flatten bvv) tmps))) `(lambda ,bvv - ,@(hyg:untag-list body al tmps2))))) + ,@(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))))) + ,(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))))) + ,(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))))) + ,(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))))) + ,(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))))) + ,(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))) + (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))) + (list->vector + (hyg:untag-vanilla (vector->list e) al tmps))) ((not (symbol? e)) e) ((memq e tmps) e) ((assq e al) => cdr) @@ -214,6 +259,7 @@ ;;;; End of hygiene filter. + ;;; finds the leftmost index of list l where something equal to x ;;; occurs (define mbe:position @@ -223,6 +269,14 @@ ((equal? (car l) x) i) (else (loop (cdr l) (+ i 1))))))) +;;; (mbe:append-map f l) == (apply append (map f l)) + +(define mbe:append-map + (lambda (f l) + (let loop ((l l)) + (if (null? l) '() + (append (f (car l)) (loop (cdr l))))))) + ;;; tests if expression e matches pattern p where k is the list of ;;; keywords (define mbe:matches-pattern? @@ -301,11 +355,26 @@ ;;; 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))) + (let ((sub-envs-list + (let loop ((r r) (sub-envs-list '())) + (if (null? r) (nreverse sub-envs-list) + (let ((c (car r))) + (loop (cdr r) + (if (mbe:contained-in? nestings (car c)) + (cons (cdr c) sub-envs-list) + sub-envs-list))))))) + (case (length sub-envs-list) + ((0) #f) + ((1) (car sub-envs-list)) + (else + (let loop ((sub-envs-list sub-envs-list) (final-sub-envs '())) + (if (some null? sub-envs-list) (nreverse final-sub-envs) + (loop (map cdr sub-envs-list) + (cons (mbe:append-map car sub-envs-list) + final-sub-envs))))))))) ;;; checks if nestings v and y have an intersection (define mbe:contained-in? @@ -337,36 +406,36 @@ (defmacro define-syntax (macro-name syn-rules) (if (or (not (pair? syn-rules)) - (not (eq? (car syn-rules) 'syntax-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))) + (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)) + (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)))))))) + `((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) |