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