396 lines
12 KiB
Plaintext
396 lines
12 KiB
Plaintext
|
;;;; "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
|
||
|
|
;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).
|
||
|
|
;;; corrections, Apr. 24, 1997.
|
||
|
|
;;; revised Aug. 30 1999 for STk (eg@unice.fr)
|
||
|
|
;;;
|
||
|
|
;;; Last file update: 31-Aug-1999 15:56 (eg)
|
||
|
|
;;;
|
||
|
|
;;; A vanilla implementation of hygienic macro-by-example as described
|
||
|
|
;;; by Eugene Kohlbecker and in R4RS Appendix.
|
||
|
|
|
||
|
|
|
||
|
|
(define-module MBE
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Scheme utilities
|
||
|
|
;;;
|
||
|
|
(define (reverse! l)
|
||
|
|
(let loop ((l l) (r '()))
|
||
|
|
(if (null? l)
|
||
|
|
r
|
||
|
|
(let ((d (cdr l)))
|
||
|
|
(set-cdr! l r)
|
||
|
|
(loop d l)))))
|
||
|
|
|
||
|
|
;=============================================================================
|
||
|
|
|
||
|
|
(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
|
||
|
|
(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 (gensym)))
|
||
|
|
(cons te (cons (cons te e) al))))))
|
||
|
|
(else (cons e al)))))
|
||
|
|
|
||
|
|
;;untagging
|
||
|
|
|
||
|
|
(define hyg:untag
|
||
|
|
(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))))
|
||
|
|
(hyg:untag-vanilla e al tmps))))
|
||
|
|
|
||
|
|
(define hyg:untag-list
|
||
|
|
(lambda (ee al tmps)
|
||
|
|
(map (lambda (e)
|
||
|
|
(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)))))
|
||
|
|
|
||
|
|
(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 (append! (hyg:flatten bvv) tmps)))
|
||
|
|
`(lambda ,bvv
|
||
|
|
,@(hyg:untag-list body al tmps2)))))
|
||
|
|
|
||
|
|
(define hyg:untag-letrec
|
||
|
|
(lambda (varvals body al tmps)
|
||
|
|
(let ((tmps (append! (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 (append! (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 (append! (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 (append! (reverse! (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 (append! (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)
|
||
|
|
(let loop ((e e) (r '()))
|
||
|
|
(cond ((pair? e) (loop (car e)
|
||
|
|
(loop (cdr e) r)))
|
||
|
|
((null? e) r)
|
||
|
|
(else (cons e r))))))
|
||
|
|
|
||
|
|
;;;; 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 (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)
|
||
|
|
(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)
|
||
|
|
(some (lambda (v_i)
|
||
|
|
(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))
|
||
|
|
(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
|
||
|
|
|
||
|
|
(define-macro (define-syntax macro-name syn-rules)
|
||
|
|
(if (or (not (pair? syn-rules))
|
||
|
|
(not (eq? (car syn-rules) 'syntax-rules)))
|
||
|
|
(error "define-syntax: in ~S, bad syntax-rules" macro-name syn-rules)
|
||
|
|
(let ((keywords (cons macro-name (cadr syn-rules)))
|
||
|
|
(clauses (cddr syn-rules)))
|
||
|
|
`(define-macro (,macro-name . macro-arg)
|
||
|
|
(let ((macro-arg (cons ',macro-name macro-arg))
|
||
|
|
(keywords ',keywords)
|
||
|
|
(mbe:matches-pattern? (with-module mbe mbe:matches-pattern?))
|
||
|
|
(mbe:expand-pattern (with-module mbe mbe:expand-pattern))
|
||
|
|
(mbe:get-bindings (with-module mbe mbe:get-bindings))
|
||
|
|
(hyg:tag (with-module mbe hyg:tag))
|
||
|
|
(hyg:untag (with-module mbe hyg:untag))
|
||
|
|
(hyg:flatten (with-module mbe hyg:flatten)))
|
||
|
|
|
||
|
|
(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
|
||
|
|
(append! (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 (error "~S: no matching clause: ~S"
|
||
|
|
',macro-name ',clauses))))))))
|
||
|
|
|
||
|
|
)
|
||
|
|
|
||
|
|
;; Make only define-syntax visible from MBE
|
||
|
|
(with-module Scheme
|
||
|
|
(define define-syntax (with-module MBE define-syntax)))
|
||
|
|
|
||
|
|
(provide "defsyntax")
|