summaryrefslogtreecommitdiffstats
path: root/mbe.scm
diff options
context:
space:
mode:
Diffstat (limited to 'mbe.scm')
-rw-r--r--mbe.scm323
1 files changed, 196 insertions, 127 deletions
diff --git a/mbe.scm b/mbe.scm
index d39a2f7..df88857 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, 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)