home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / scm / !Scm / slib / mbe < prev    next >
Encoding:
Text File  |  1994-03-07  |  9.4 KB  |  335 lines
  1. ;;;; mbe.scm "Macro by Example" (Eugene Kohlbecker, r4rs)
  2. ;;; Dorai Sitaram, dorai@cs.rice.edu, 1991, revised Sept. 3, 1992,
  3. ;;; revised Dec. 6, 1993 to r4rs syntax (if not semantics).
  4. ;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu).
  5.  
  6. ;;; A vanilla implementation of Macro-by-Example (Eugene
  7. ;;; Kohlbecker, r4rs).  This file requires defmacro.
  8.  
  9. (require 'common-list-functions)    ;nconc, some, every
  10. ;(require 'rev2-procedures)        ;append! alternate for nconc
  11. (require 'rev4-optional-procedures)    ;list-tail
  12.  
  13. ;;; A vanilla implementation of a hygiene filter for define-syntax
  14.  
  15. ;(define hyg:tag-generic
  16. ;  (lambda (e kk tmps) e))
  17.  
  18. ;;; if you don't want the hygiene filter, comment out the following
  19. ;;; s-exp and uncomment the previous one.
  20.  
  21. (define hyg:tag-generic
  22.   (lambda (e kk tmps)
  23.     (if (pair? e)
  24.     (let ((a (car e)))
  25.       (case a
  26.         ((quote) `(quote ,(hyg:tag-vanilla (cadr e) kk tmps)))
  27.         ((if begin)
  28.          `(,a ,@(map (lambda (e1) (hyg:tag-generic e1 kk tmps))
  29.              (cdr e))))
  30.         ((set! define)
  31.          `(,a ,(hyg:tag-vanilla (cadr e) kk tmps)
  32.           ,@(map (lambda (e1) (hyg:tag-generic e1 kk tmps))
  33.              (cddr e))))
  34.         ((lambda) (hyg:tag-lambda (cdr e) kk tmps))
  35.         ((letrec) (hyg:tag-letrec (cdr e) kk tmps))
  36.         ((let) (hyg:tag-let (cdr e) kk tmps))
  37.         ((let*) (hyg:tag-let-star (cdr e) kk tmps))
  38.         ((do) (hyg:tag-do (cdr e) kk tmps))
  39.         ((case)
  40.          `(case ,(hyg:tag-generic (cadr e) kk tmps)
  41.         ,@(map
  42.            (lambda (cl)
  43.              `(,(hyg:tag-vanilla (car cl) kk tmps)
  44.                ,@(map
  45.               (lambda (e1)
  46.                 (hyg:tag-generic e1 kk tmps))
  47.               (cdr cl))))
  48.            (cddr e))))
  49.         ((cond)
  50.          `(cond ,@(map
  51.                (lambda (cl)
  52.              (map (lambda (e1)
  53.                 (hyg:tag-generic e1 kk tmps))
  54.                   cl))
  55.                (cdr e))))
  56.         (else (map (lambda (e1)
  57.              (hyg:tag-generic e1 kk tmps))
  58.                e))))
  59.     (hyg:tag-vanilla e kk tmps))))
  60.  
  61. (define hyg:tag-vanilla
  62.   (lambda (e kk tmps)
  63.     (cond ((symbol? e)
  64.        (cond ((memq e kk) e)
  65.          ((assq e tmps) => cdr)
  66.          (else e)))
  67.       ((pair? e)
  68.        (cons (hyg:tag-vanilla (car e) kk tmps)
  69.          (hyg:tag-vanilla (cdr e) kk tmps)))
  70.       (else e))))
  71.  
  72. (define hyg:tag-lambda
  73.   (lambda (e kk tmps)
  74.     (let* ((bvv (car e))
  75.        (tmps2 (append
  76.            (map (lambda (v) (cons v (gentemp)))
  77.             (hyg:flatten bvv))
  78.            tmps)))
  79.       `(lambda
  80.        ,(hyg:tag-vanilla bvv kk tmps2)
  81.      ,@(map
  82.         (lambda (e1)
  83.           (hyg:tag-vanilla e1 kk tmps2))
  84.         (cdr e))))))
  85.  
  86. (define hyg:flatten
  87.   (lambda (e)
  88.     (let loop ((e e) (r '()))
  89.       (cond ((pair? e) (loop (car e)
  90.                  (loop (cdr e) r)))
  91.         ((null? e) r)
  92.         (else (cons e r))))))
  93.  
  94. (define hyg:tag-letrec
  95.   (lambda (e kk tmps)
  96.     (let* ((varvals (car e))
  97.        (tmps2 (append
  98.            (map (lambda (v) (cons v (gentemp)))
  99.             (map car varvals))
  100.            tmps)))
  101.       `(letrec ,(map
  102.          (lambda (varval)
  103.            `(,(hyg:tag-vanilla (car varval)
  104.                        kk tmps2)
  105.              ,(hyg:tag-generic (cadr varval)
  106.                        kk tmps2)))
  107.          varvals)
  108.      ,@(map (lambda (e1)
  109.           (hyg:tag-generic e1 kk tmps2))
  110.         (cdr e))))))
  111.  
  112. (define hyg:tag-let
  113.   (lambda (e kk tmps)
  114.     (let* ((varvals (car e))
  115.        (tmps2 (append (map (lambda (v) (cons v (gentemp)))
  116.                    (map car varvals))
  117.               tmps)))
  118.       `(let
  119.        ,(let loop ((varvals varvals)
  120.                (i (length varvals)))
  121.           (if (null? varvals) '()
  122.           (let ((varval (car varvals))
  123.             (tmps3 (list-tail tmps2 i)))
  124.             (cons `(,(hyg:tag-vanilla (car varval)
  125.                           kk tmps2)
  126.                 ,(hyg:tag-generic (cadr varval)
  127.                           kk tmps3))
  128.               (loop (cdr varvals) (- i 1))))))
  129.      ,@(map
  130.         (lambda (e1)
  131.           (hyg:tag-generic e1 kk tmps2))
  132.         (cdr e))))))
  133.  
  134. (define hyg:tag-do
  135.   (lambda (e kk tmps)
  136.     (let* ((varinistps (car e))
  137.        (tmps2 (append (map (lambda (v) (cons v (gentemp)))
  138.                    (map car varinistps))
  139.               tmps)))
  140.       `(do
  141.        ,(let loop ((varinistps varinistps)
  142.                (i (length varinistps)))
  143.           (if (null? varinistps) '()
  144.           (let ((varinistp (car varinistps))
  145.             (tmps3 (list-tail tmps2 i)))
  146.             (cons `(,(hyg:tag-vanilla (car varinistp)
  147.                           kk tmps2)
  148.                 ,(hyg:tag-vanilla (cadr varinistp)
  149.                           kk tmps2)
  150.                 ,@(hyg:tag-generic (cddr varinistp)
  151.                            kk tmps3))
  152.               (loop (cdr varinistps) (- i 1))))))
  153.        ,(map (lambda (e1)
  154.            (hyg:tag-generic e1 kk tmps)) (cadr e))
  155.      ,@(map
  156.         (lambda (e1)
  157.           (hyg:tag-generic e1 kk tmps2))
  158.         (cddr e))))))
  159.  
  160. (define hyg:tag-let-star
  161.   (lambda (e kk tmps)
  162.     (let* ((varvals (car e))
  163.        (tmps2 (append (reverse (map (lambda (v) (cons v (gentemp)))
  164.                     (map car varvals)))
  165.               tmps)))
  166.       `(let*
  167.        ,(let loop ((varvals varvals)
  168.                (i (- (length varvals) 1)))
  169.           (if (null? varvals) '()
  170.           (let ((varval (car varvals))
  171.             (tmps3 (list-tail tmps2 i)))
  172.             (cons `(,(hyg:tag-vanilla (car varval)
  173.                           kk tmps3)
  174.                 ,(hyg:tag-generic (cadr varval)
  175.                           kk (cdr tmps3)))
  176.               (loop (cdr varvals) (- i 1))))))
  177.      ,@(map
  178.         (lambda (e1)
  179.           (hyg:tag-generic e1 kk tmps2))
  180.         (cdr e))))))
  181.  
  182. ;;;; End of hygiene filter.
  183.  
  184. ;;; finds the leftmost index of list l where something equal to x
  185. ;;; occurs
  186. (define mbe:position
  187.   (lambda (x l)
  188.     (let loop ((l l) (i 0))
  189.       (cond ((not (pair? l)) #f)
  190.         ((equal? (car l) x) i)
  191.         (else (loop (cdr l) (+ i 1)))))))
  192.  
  193. ;;; tests if expression e matches pattern p where k is the list of
  194. ;;; keywords
  195. (define mbe:matches-pattern?
  196.   (lambda (p e k)
  197.     (cond ((mbe:ellipsis? p)
  198.        (and (or (null? e) (pair? e))
  199.         (let* ((p-head (car p))
  200.                (p-tail (cddr p))
  201.                (e-head=e-tail (mbe:split-at-ellipsis e p-tail)))
  202.           (and e-head=e-tail
  203.                (let ((e-head (car e-head=e-tail))
  204.                  (e-tail (cdr e-head=e-tail)))
  205.              (and (comlist:every
  206.                    (lambda (x) (mbe:matches-pattern? p-head x k))
  207.                    e-head)
  208.                   (mbe:matches-pattern? p-tail e-tail k)))))))
  209.       ((pair? p)
  210.        (and (pair? e)
  211.         (mbe:matches-pattern? (car p) (car e) k)
  212.         (mbe:matches-pattern? (cdr p) (cdr e) k)))
  213.       ((symbol? p) (if (memq p k) (eq? p e) #t))
  214.       (else (equal? p e)))))
  215.  
  216. ;;; gets the bindings of pattern variables of pattern p for
  217. ;;; expression e;
  218. ;;; k is the list of keywords
  219. (define mbe:get-bindings
  220.   (lambda (p e k)
  221.     (cond ((mbe:ellipsis? p)
  222.        (let* ((p-head (car p))
  223.           (p-tail (cddr p))
  224.           (e-head=e-tail (mbe:split-at-ellipsis e p-tail))
  225.           (e-head (car e-head=e-tail))
  226.           (e-tail (cdr e-head=e-tail)))
  227.          (cons (cons (mbe:get-ellipsis-nestings p-head k)
  228.              (map (lambda (x) (mbe:get-bindings p-head x k))
  229.               e-head))
  230.            (mbe:get-bindings p-tail e-tail k))))
  231.       ((pair? p)
  232.        (append (mbe:get-bindings (car p) (car e) k)
  233.          (mbe:get-bindings (cdr p) (cdr e) k)))
  234.       ((symbol? p)
  235.        (if (memq p k) '() (list (cons p e))))
  236.       (else '()))))
  237.  
  238. ;;; expands pattern p using environment r;
  239. ;;; k is the list of keywords
  240. (define mbe:expand-pattern
  241.   (lambda (p r k)
  242.     (cond ((mbe:ellipsis? p)
  243.        (append (let* ((p-head (car p))
  244.               (nestings (mbe:get-ellipsis-nestings p-head k))
  245.               (rr (mbe:ellipsis-sub-envs nestings r)))
  246.              (map (lambda (r1)
  247.                 (mbe:expand-pattern p-head (append r1 r) k))
  248.               rr))
  249.          (mbe:expand-pattern (cddr p) r k)))
  250.       ((pair? p)
  251.        (cons (mbe:expand-pattern (car p) r k)
  252.          (mbe:expand-pattern (cdr p) r k)))
  253.       ((symbol? p)
  254.        (if (memq p k) p
  255.          (let ((x (assq p r)))
  256.            (if x (cdr x) p))))
  257.       (else p))))
  258.  
  259. ;;; returns a list that nests a pattern variable as deeply as it
  260. ;;; is ellipsed
  261. (define mbe:get-ellipsis-nestings
  262.   (lambda (p k)
  263.     (let sub ((p p))
  264.       (cond ((mbe:ellipsis? p) (cons (sub (car p)) (sub (cddr p))))
  265.         ((pair? p) (append (sub (car p)) (sub (cdr p))))
  266.         ((symbol? p) (if (memq p k) '() (list p)))
  267.         (else '())))))
  268.  
  269. ;;; finds the subenvironments in r corresponding to the ellipsed
  270. ;;; variables in nestings
  271. (define mbe:ellipsis-sub-envs
  272.   (lambda (nestings r)
  273.     (comlist:some (lambda (c)
  274.             (if (mbe:contained-in? nestings (car c)) (cdr c) #f))
  275.           r)))
  276.  
  277. ;;; checks if nestings v and y have an intersection
  278. (define mbe:contained-in?
  279.   (lambda (v y)
  280.     (if (or (symbol? v) (symbol? y)) (eq? v y)
  281.     (comlist:some (lambda (v_i)
  282.             (comlist:some (lambda (y_j)
  283.                     (mbe:contained-in? v_i y_j))
  284.                       y))
  285.               v))))
  286.  
  287. ;;; split expression e so that its second half matches with
  288. ;;; pattern p-tail
  289. (define mbe:split-at-ellipsis
  290.   (lambda (e p-tail)
  291.     (if (null? p-tail) (cons e '())
  292.       (let ((i (mbe:position (car p-tail) e)))
  293.     (if i (cons (butlast e (- (length e) i))
  294.             (list-tail e i))
  295.         (error 'mbe:split-at-ellipsis 'bad-arg))))))
  296.  
  297. ;;; tests if x is an ellipsing pattern, i.e., of the form
  298. ;;; (blah ... . blah2)
  299. (define mbe:ellipsis?
  300.   (lambda (x)
  301.     (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...))))
  302.  
  303. ;define-syntax
  304.  
  305. (defmacro define-syntax (macro-name syn-rules)
  306.   (if (or (not (pair? syn-rules))
  307.       (not (eq? (car syn-rules) 'syntax-rules)))
  308.       (error 'define-syntax 'not-an-r4rs-high-level-macro
  309.          macro-name syn-rules)
  310.       (let ((keywords (cons macro-name (cadr syn-rules)))
  311.         (clauses (cddr syn-rules)))
  312.     `(defmacro ,macro-name macro-arg
  313.        (let ((macro-arg (cons ',macro-name macro-arg))
  314.          (keywords ',keywords))
  315.          (cond ,@(map
  316.               (lambda (clause)
  317.             (let ((in-pattern (car clause))
  318.                   (out-pattern (cadr clause)))
  319.               `((mbe:matches-pattern? ',in-pattern macro-arg
  320.                           keywords)
  321.                 (hyg:tag-generic
  322.                  (mbe:expand-pattern
  323.                   ',out-pattern
  324.                   (mbe:get-bindings ',in-pattern macro-arg
  325.                         keywords)
  326.                   keywords)
  327.                  (nconc
  328.                   (hyg:flatten ',in-pattern)
  329.                   keywords)
  330.                  '()))))
  331.               clauses)
  332.            (else (error ',macro-name 'no-matching-clause
  333.                 ',clauses))))))))
  334. ;eof
  335.