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