summaryrefslogtreecommitdiffstats
path: root/mbe.scm
diff options
context:
space:
mode:
Diffstat (limited to 'mbe.scm')
-rw-r--r--mbe.scm402
1 files changed, 207 insertions, 195 deletions
diff --git a/mbe.scm b/mbe.scm
index e48e1f1..d39a2f7 100644
--- a/mbe.scm
+++ b/mbe.scm
@@ -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)