summaryrefslogtreecommitdiffstats
path: root/mbe.scm
diff options
context:
space:
mode:
Diffstat (limited to 'mbe.scm')
-rw-r--r--mbe.scm362
1 files changed, 362 insertions, 0 deletions
diff --git a/mbe.scm b/mbe.scm
new file mode 100644
index 0000000..e48e1f1
--- /dev/null
+++ b/mbe.scm
@@ -0,0 +1,362 @@
+;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, r4rs)
+;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, revised Sept. 3, 1992,
+;
+;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).
+
+;;; A vanilla implementation of Macro-by-Example (Eugene
+;;; Kohlbecker, r4rs). 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:tag-generic
+; (lambda (e kk tmps) e))
+
+;;; if you don't want the hygiene filter, comment out the following
+;;; s-exp and uncomment the previous one.
+
+(define hyg:tag-generic
+ (lambda (e kk 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))))
+
+(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: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: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))))))
+
+(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
+;;; 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 (comlist: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)
+ (comlist: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)
+ (comlist:some (lambda (v_i)
+ (comlist: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)
+ (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))))))))
+
+(define macro:eval slib:eval)
+(define macro:load slib:load)
+(provide 'macro)
+;eof