home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Tools⁄Additions / MacScheme20 / Contributed / ExtendSyntax / extendsyntax.sch < prev   
Encoding:
Text File  |  1988-12-15  |  13.5 KB  |  388 lines  |  [TEXT/EDIT]
  1. ; This code, contributed by Jeff De Vries, has been modified to remove the
  2. ; assumption that #f is the same as the empty list.  Three changes were
  3. ; required: changing a null? to a not in add-car, add-cdr, and gen.
  4. ;
  5. ; From: jdevries@ads.arpa (Jeff De Vries)
  6. ; Subject: Extend-Syntax for Everybody!
  7. ; Date: 15 Nov 87 20:54:13 GMT
  8. ; 
  9. ; By popular demand I have decided to go ahead and post the code for the
  10. ; MacScheme version of extend-syntax.  I had (have?) over 40 requests,
  11. ; (some of which I can't seem to respond to due to always getting bounced),
  12. ; plus other indicators that some people are just waiting for me to post it.
  13. ; To those of you who have no interest in this, I apologize for the long
  14. ; posting, (just hit your 'junk' key, if you have one).  
  15. ; 
  16. ; But first, a few words:
  17. ; 
  18. ; The theoretical work and basic design behind extend-syntax was the work of 
  19. ; Eugene Kohlbecker.  It was part of his Ph.D. dissertation, "Syntactic 
  20. ; Extensions in the Programming Language LISP", (Indiana University, 1986).  
  21. ; The enhanced version of the code that I used for the MacScheme version was 
  22. ; written by R. Kent Dybvig, and made available by him.
  23. ; 
  24. ; A more complete description of Kent's book is:
  25. ;  The Scheme Programming Language
  26. ;  R. Kent Dybvig
  27. ;  Prentice-Hall, Englewood Cliffs, New Jersey, 07632 (1987)
  28. ;  Library of Congress Catalog Card Number 86-63489
  29. ; 
  30. ; If you are using a version of Scheme other than MacScheme, you should be
  31. ; able to convert this to whatever you are using.  The main thing to change
  32. ; is the way macros are defined.  There are two macros, (extend-syntax and
  33. ; extend-syntax/code), plus the macro defining form embedded inside of
  34. ; extend-syntax.  You may have to add (or delete) a support function or two.
  35. ; 
  36. ; ENJOY!!! :-)
  37. ; 
  38. ; Jeff
  39. ; 
  40. ; ------------------------distribution starts here------------------------
  41. ; Here is the code for extend-syntax.  It includes the code for:
  42. ;  when
  43. ;  unless
  44. ;  andmap
  45. ;  syntax-match?
  46. ;  extend-syntax
  47. ;  extend-syntax/code
  48. ; 
  49. ; To load it, just enter
  50. ;  (load "extend.sch")
  51. ; 
  52. ; It takes a while to load and will print out:
  53. ;  when
  54. ;  unless
  55. ;  andmap
  56. ;  syntax-match?
  57. ;  extend-syntax/code
  58. ; (note: extend-syntax gets compiled even though its name doesn't get
  59. ;  printed.  It doesn't get printed because it's inside the LET)
  60. ; 
  61. ; After you load it, you may want to do a (dumpheap)  See the MacScheme
  62. ; manual for details.
  63. ; 
  64. ; The documentation for extend-syntax is in "The Scheme Programming
  65. ; Language" by R. Kent Dybvig.  Buy the book.  (No, I don't get any
  66. ; kickbacks).  extend-syntax/code returns the source for the
  67. ; lambda expression that would have been bound to the macro, which is
  68. ; helpful during debugging and for getting a feel for how extend-syntax
  69. ; works.  You might try (pretty-print (extend-syntax/code --- etc. if
  70. ; you want to be able to read it easily.  Note that the output isn't
  71. ; directly useable because of gensym'ed variables and how MacScheme
  72. ; prints quasiquotes, etc.  Use extend-syntax to make the macros.
  73. ; 
  74. ; If you have any comments or problems, feel free to contact me.  I won't
  75. ; promise anything, but I'll give it a look.  If you port the code to another
  76. ; version of Scheme, I would be interested in hearing about it.
  77. ; 
  78. ; Jeff De Vries
  79. ; (ARPA: jdevries@ads.arpa)
  80. ; DISCLAIMER: All the usual stuff...
  81. ; 
  82. ; -----------------------------snip here---------------------------------
  83. ;;; extend.sch
  84. ;;; Copyright (C) 1987 Cadence Research Systems
  85. ;;; Permission to copy this software, in whole or in part, to use this
  86. ;;; software for any lawful noncommercial purpose, and to redistribute
  87. ;;; this software is granted subject to the restriction that all copies
  88. ;;; made of this software must include this copyright notice in full.
  89. ;;; Cadence makes no warranties or representations of any kind, either
  90. ;;; express or implied, including but not limited to implied warranties
  91. ;;; of merchantability or fitness for any particular purpose.
  92.  
  93. ;;; The basic design of extend-syntax is due to Eugene Kohlbecker.  See
  94. ;;; "E. Kohlbecker: Syntactic Extensions in the Programming Language Lisp",
  95. ;;; Ph.D.  Dissertation, Indiana University, 1986."  The structure of "with"
  96. ;;; pattern/value clauses, the method for compiling extend-syntax into
  97. ;;; Scheme code, and the actual implementation are due to Kent Dybvig.
  98.  
  99. ;;; Made available courtesy R. Kent Dybvig
  100. ;;; MacScheme conversion by Jeff De Vries
  101. ;;; note: requires the use of MacScheme Version 1.2 or greater
  102.  
  103. ;;; the following routines are provided for compatibility with TSPL:
  104. (macro when
  105.        (lambda (args)
  106.          `(if ,(cadr args)
  107.               (begin ,@(cddr args))
  108.               #f)))
  109. (macro unless
  110.        (lambda (args)
  111.          `(if ,(cadr args)
  112.               #t
  113.               (begin ,@(cddr args)))))
  114.  
  115. (define (andmap p . args)
  116.   ;; use "first-finish" rule
  117.   (let andmap ((args args) (value #t))
  118.     (if (let any-at-end? ((ls args))
  119.           (and (pair? ls)
  120.                (or (not (pair? (car ls)))
  121.                    (any-at-end? (cdr ls)))))
  122.         value
  123.         (let ((value (apply p (map car args))))
  124.           (and value (andmap (map cdr args) value))))))
  125.  
  126. ;;; syntax-match? is used by extend-syntax to choose among clauses and
  127. ;;; to check for syntactic errors.  It is also available to the user.
  128. (define syntax-match?
  129.   (lambda (keys pat exp)
  130.     (cond
  131.      ((symbol? pat) (if (memq pat keys) (eq? exp pat) #t))
  132.      ((pair? pat)
  133.       (if (equal? (cdr pat) '(...))
  134.           (let f ((lst exp))
  135.             (or (null? lst)
  136.                 (and (pair? lst)
  137.                      (syntax-match? keys (car pat) (car lst))
  138.                      (f (cdr lst)))))
  139.           (and (pair? exp)
  140.                (syntax-match? keys (car pat) (car exp))
  141.                (syntax-match? keys (cdr pat) (cdr exp)))))
  142.      (else (equal? exp pat)))))
  143.  
  144. ;;; The main code!
  145. (let ()
  146.   (define id
  147.     (lambda (name access control)
  148.       (list name access control)))
  149.   (define id-name car)
  150.   (define id-access cadr)
  151.   (define id-control caddr)
  152.   
  153.   (define loop
  154.     (lambda ()
  155.       (list '())))
  156.   (define loop-ids car)
  157.   (define loop-ids! set-car!)
  158.   
  159.   (define c...rs
  160.     `((car caar . cdar)
  161.       (cdr cadr . cddr)
  162.       (caar caaar . cdaar)
  163.       (cadr caadr . cdadr)
  164.       (cdar cadar . cddar)
  165.       (cddr caddr . cdddr)
  166.       (caaar caaaar . cdaaar)
  167.       (caadr caaadr . cdaadr)
  168.       (cadar caadar . cdadar)
  169.       (caddr caaddr . cdaddr)
  170.       (cdaar cadaar . cddaar)
  171.       (cdadr cadadr . cddadr)
  172.       (cddar caddar . cdddar)
  173.       (cdddr cadddr . cddddr)))
  174.   
  175.   (define add-car
  176.     (lambda (access)
  177.       (let ((x (and (pair? access) (assq (car access) c...rs))))
  178.         (if (not x)
  179.             `(car ,access)
  180.             `(,(cadr x) ,@(cdr access))))))
  181.   
  182.   (define add-cdr
  183.     (lambda (access)
  184.       (let ((x (and (pair? access) (assq (car access) c...rs))))
  185.         (if (not x)
  186.             `(cdr ,access)
  187.             `(,(cddr x) ,@(cdr access))))))
  188.   
  189.   (define parse
  190.     (lambda (keys pat acc cntl ids)
  191.       (cond
  192.        ((symbol? pat)
  193.         (if (memq pat keys)
  194.             ids
  195.             (cons (id pat acc cntl) ids)))
  196.        ((pair? pat)
  197.         (if (equal? (cdr pat) '(...))
  198.             (let ((x (gensym)))
  199.               (parse keys (car pat) x (id x acc cntl) ids))
  200.             (parse keys
  201.                    (car pat)
  202.                    (add-car acc)
  203.                    cntl
  204.                    (parse keys (cdr pat) (add-cdr acc) cntl ids))))
  205.        (else ids))))
  206.   
  207.   (define gen
  208.     (lambda (keys exp ids loops)
  209.       (cond
  210.        ((symbol? exp)
  211.         (let ((id (lookup exp ids)))
  212.           (if (not id)
  213.               exp
  214.               (begin
  215.                (add-control! (id-control id) loops)
  216.                (list 'unquote (id-access id))))))
  217.        ((pair? exp)
  218.         (cond
  219.          ((eq? (car exp) 'with)
  220.           (unless (syntax-match? '(with) '(with ((p x) ...) e) exp)
  221.                   (error 'extend-syntax "invalid 'with' form" exp))
  222.           (list 'unquote
  223.                 (gen-with
  224.                  keys
  225.                  (map car (cadr exp))
  226.                  (map cadr (cadr exp))
  227.                  (caddr exp)
  228.                  ids
  229.                  loops)))
  230.          ((and (pair? (cdr exp)) (eq? (cadr exp) '...))
  231.           (let ((x (loop)))
  232.             (make-loop
  233.              x
  234.              (gen keys (car exp) ids (cons x loops))
  235.              (gen keys (cddr exp) ids loops))))
  236.          (else
  237.           (let ((a (gen keys (car exp) ids loops))
  238.                 (d (gen keys (cdr exp) ids loops)))
  239.             (if (and (pair? d) (eq? (car d) 'unquote))
  240.                 (list a (list 'unquote-splicing (cadr d)))
  241.                 (cons a d))))))
  242.        (else exp))))
  243.   
  244.   (define gen-with
  245.     (lambda (keys pats exps body ids loops)
  246.       (if (null? pats)
  247.           (make-quasi (gen keys body ids loops))
  248.           (let ((p (car pats)) (e (car exps)) (g (gensym)))
  249.             `(let ((,g ,(gen-quotes keys e ids loops)))
  250.                   (if (syntax-match? '() ',p ,g)
  251.                       ,(gen-with
  252.                         keys
  253.                         (cdr pats)
  254.                         (cdr exps)
  255.                         body
  256.                         (parse '() p g '() ids)
  257.                         loops)
  258.                       (error ',(car keys)
  259.                              "does not fit 'with' pattern"
  260.                              ,g
  261.                               ',p)))))))
  262.   
  263.   (define gen-quotes
  264.     (lambda (keys exp ids loops)
  265.       (cond
  266.        ((syntax-match? '(quote) '(quote x) exp)
  267.         (make-quasi (gen keys (cadr exp) ids loops)))
  268.        ((pair? exp)
  269.         (cons (gen-quotes keys (car exp) ids loops)
  270.               (gen-quotes keys (cdr exp) ids loops)))
  271.        (else exp))))
  272.   
  273.   (define lookup
  274.     (lambda (sym ids)
  275.       (let loop ((ls ids))
  276.         (cond
  277.          ((null? ls) #f)
  278.          ((eq? (id-name (car ls)) sym) (car ls))
  279.          (else (loop (cdr ls)))))))
  280.   
  281.   (define add-control!
  282.     (lambda (id loops)
  283.       (unless (null? id)
  284.               (when (null? loops)
  285.                     (error 'extend-syntax "missing ellipsis in expansion"))
  286.               (let ((x (loop-ids (car loops))))
  287.                 (unless (memq id x)
  288.                         (loop-ids! (car loops) (cons id x))))
  289.               (add-control! (id-control id) (cdr loops)))))
  290.   
  291.   (define make-loop
  292.     (lambda (loop body tail)
  293.       (let ((ids (loop-ids loop)))
  294.         (when (null? ids)
  295.               (error 'extend-syntax "extra ellipsis in expansion"))
  296.         (cond
  297.          ((equal? body (list 'unquote (id-name (car ids))))
  298.           (if (null? tail)
  299.               (list 'unquote (id-access (car ids)))
  300.               (cons (list 'unquote-splicing (id-access (car ids)))
  301.                     tail)))
  302.          ((and (null? (cdr ids))
  303.                (syntax-match? '(unquote) '(unquote (f x)) body)
  304.                (eq? (cadadr body) (id-name (car ids))))
  305.           (let ((x `(map ,(caadr body) ,(id-access (car ids)))))
  306.             (if (null? tail)
  307.                 (list 'unquote x)
  308.                 (cons (list 'unquote-splicing x) tail))))
  309.          (else
  310.           (let ((x `(map (lambda ,(map id-name ids) ,(make-quasi body))
  311.                          ,@(map id-access ids))))
  312.             (if (null? tail)
  313.                 (list 'unquote x)
  314.                 (cons (list 'unquote-splicing x) tail))))))))
  315.   
  316.   (define make-quasi
  317.     (lambda (exp)
  318.       (if (and (pair? exp) (eq? (car exp) 'unquote))
  319.           (cadr exp)
  320.           (list 'quasiquote exp))))
  321.   
  322.   (define make-clause
  323.     (lambda (keys cl x)
  324.       (cond
  325.        ((syntax-match? '() '(pat fender exp) cl)
  326.         (let ((pat (car cl)) (fender (cadr cl)) (exp (caddr cl)))
  327.           (let ((ids (parse keys pat x '() '())))
  328.             `((and (syntax-match? ',keys ',pat ,x)
  329.                    ,(gen-quotes keys fender ids '()))
  330.               ,(make-quasi (gen keys exp ids '()))))))
  331.        ((syntax-match? '() '(pat exp) cl)
  332.         (let ((pat (car cl)) (exp (cadr cl)))
  333.           (let ((ids (parse keys pat x '() '())))
  334.             `((syntax-match? ',keys ',pat ,x)
  335.               ,(make-quasi (gen keys exp ids '()))))))
  336.        (else
  337.         (error 'extend-syntax "invalid clause" cl)))))
  338.   
  339.   (define make-syntax
  340.     (let ((x (gensym "x")))
  341.       (lambda (keys clauses)
  342.         `(lambda (,x)
  343.                  (cond
  344.                   ,@(map (lambda (cl) (make-clause keys cl x)) clauses)
  345.                     (else
  346.                      (error ',(car keys) "invalid syntax" ,x)))))))
  347.   
  348.   (macro extend-syntax
  349.          (lambda (x)
  350.            (cond
  351.             ((and
  352.               (syntax-match?
  353.                '(extend-syntax)
  354.                '(extend-syntax (key1 key2 ...) clause ...)
  355.                x)
  356.               (andmap symbol? `(,(caadr x) ,@(cdadr x))))
  357.              (let
  358.                ((f (make-syntax `(,(caadr x) ,@(cdadr x)) (cddr x))))
  359.                (if (syntax-match? '() 'proc f)
  360.                    `(macro ,(caadr x) ,f)
  361.                    (error 'extend-syntax
  362.                           "does not fit 'with' pattern"
  363.                           f
  364.                           'proc))))
  365.             (else (error 'extend-syntax "invalid syntax" x)))))
  366.   
  367.   (macro extend-syntax/code
  368.          (lambda (x)
  369.            (cond
  370.             ((and
  371.               (syntax-match?
  372.                '(extend-syntax/code)
  373.                '(extend-syntax/code (key1 key2 ...) clause ...)
  374.                x)
  375.               (andmap symbol? `(,(caadr x) ,@(cdadr x))))
  376.              (let
  377.                ((f (make-syntax `(,(caadr x) ,@(cdadr x)) (cddr x))))
  378.                (if (syntax-match? '() 'proc f)
  379.                    `',f
  380.                       (error 'extend-syntax/code
  381.                              "does not fit 'with' pattern"
  382.                              f
  383.                              'proc))))
  384.             (else (error 'extend-syntax/code "invalid syntax" x)))))
  385.   
  386.   ) ;;; end of let
  387. ;;; end extend.sch
  388.