home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-386-Vol-2of3.iso / c / cr-macro.zip / RULES.SCM < prev    next >
Text File  |  1990-02-16  |  5KB  |  147 lines
  1. ; Rewrite-rule compiler (a.k.a. "extend-syntax")
  2.  
  3. ; Fix bug with nested ... patterns
  4. ; Put fenders and subkeyword lists following template?
  5.  
  6. ; Example:
  7. ;
  8. ; (define-syntax or
  9. ;   (syntax-rules ()
  10. ;     ((or)        #f)
  11. ;     ((or e)      e)
  12. ;     ((or e1 e +) (let ((temp e1))
  13. ;             (if temp temp (or e +))))))
  14.  
  15. (define (r exp)                ;for testing
  16.   (rewrite-syntax-rules exp (lambda (x) x) eq?))
  17.  
  18. (define (rewrite-syntax-rules exp rename compare)
  19.   (process-rules (cddr exp) (cadr exp) rename compare))
  20.  
  21. (define (process-rules rules subkeywords rename compare)
  22.   (let ((tail '%tail%))
  23.     `(lambda (%input% %rename% %compare%) ;These should be renamed...
  24.        (let ((,tail (cdr %input%)))
  25.      (cond ,@(map (lambda (rule)
  26.             (process-rule rule tail subkeywords))
  27.               rules)
  28.            (else (syntax-error "use of macro doesn't match definition"
  29.                    %input%)))))))
  30.  
  31. (define (process-rule rule tail subkeywords)
  32.   (if (not (= (length rule) 2))
  33.       (syntax-error "ill-formed rule" rule))
  34.   (let ((pattern (car rule))
  35.     (template (cadr rule)))
  36.     (let ((env (process-pattern (cdr pattern) tail null-rank subkeywords)))
  37.       `(,(process-match tail (cdr pattern) subkeywords)
  38.     (let* ,(map (lambda (z)
  39.               `(,(car z) ,(cadr z)))
  40.             env)
  41.       ,(process-template template env null-rank))))))
  42.  
  43. (define null-rank '())
  44.  
  45. ; Generate code to test whether input expression matches pattern
  46.  
  47. (define (process-match input pattern subkeywords)
  48.   (cond ((name? pattern)
  49.      (if (member pattern subkeywords)
  50.          `(%compare% ,input ',pattern)
  51.          `#t))
  52.     ((zero-or-more? pattern)
  53.      (process-list-match input (car pattern) subkeywords))
  54.     ((at-least-one? pattern)
  55.      `(and (not (null? ,input))
  56.            ,(process-list-match input (car pattern) subkeywords)))
  57.     ((pair? pattern)
  58.      `(let ((%temp% ,input))
  59.         (and (pair? %temp%)
  60.          ,(process-match `(car %temp%) (car pattern) subkeywords)
  61.          ,(process-match `(cdr %temp%) (cdr pattern) subkeywords))))
  62.     (else
  63.      `(equal? ,input ',pattern))))
  64.  
  65. (define (process-list-match input pattern subkeywords)
  66.   `(let loop ((l ,input))
  67.      (or (null? l)
  68.      (and (pair? l)
  69.           ,(process-match '(car l) pattern subkeywords)
  70.           (loop (cdr l))))))
  71.  
  72. ; Generate code to take apart the input expression
  73.  
  74. (define (process-pattern pattern path rank subkeywords)
  75.   (cond ((name? pattern)
  76.      (if (name-member pattern subkeywords)
  77.          '()
  78.          (list (list pattern path rank))))
  79.     ((or (zero-or-more? pattern)
  80.          (at-least-one? pattern))
  81.      (let ((temp '%temp%))  ;Bug -- should gensym here!!
  82.        (cons `(,temp ,path)
  83.          (map (lambda (z)
  84.             `(,(car z)
  85.               (map (lambda (%input%)
  86.                  ,(cadr z))
  87.                ,temp)
  88.               ,(caddr z)))
  89.               (process-pattern (car pattern)
  90.                        '%input%
  91.                        (cons (cadr pattern) rank)
  92.                        subkeywords)))))
  93.     ((pair? pattern)
  94.      (append (process-pattern (car pattern) `(car ,path) rank subkeywords)
  95.          (process-pattern (cdr pattern) `(cdr ,path) rank subkeywords)))
  96.     (else '())))
  97.  
  98. ; Generate code to compose the output expression according to template
  99.  
  100. (define (process-template template env rank)
  101.   (cond ((name? template)
  102.      (let ((probe (name-assoc template env)))
  103.        (if probe
  104.            (if (equal? (caddr probe) rank)
  105.            template
  106.            (syntax-error "rank error" template rank))
  107.            `(%rename% ',template))))
  108.     ((or (zero-or-more? template)
  109.          (at-least-one? template))
  110.      (let ((vars (free-template-vars (car template) env '())))
  111.        (if (null? vars)
  112.            (syntax-error "ill-formed template" template)
  113.            `(map (lambda ,vars
  114.                ,(process-template (car template)
  115.                       env
  116.                       (cons (cadr template) rank)))
  117.              ,@vars))))
  118.     ((pair? template)
  119.      `(cons ,(process-template (car template) env rank)
  120.         ,(process-template (cdr template) env rank)))
  121.     (else `',template)))
  122.  
  123. (define (free-template-vars template env free)
  124.   (cond ((name? template)
  125.      (if (and (name-assoc template env)
  126.           (not (name-member template free)))
  127.          (cons template free)
  128.          free))
  129.     ((or (zero-or-more? template)
  130.          (at-least-one? template))
  131.      (free-template-vars (cadr template) env free))
  132.     ((pair? template)
  133.      (free-template-vars (car template) env
  134.                  (free-template-vars (cdr template) env free)))
  135.     (else free)))
  136.  
  137. (define (check-cadr syms)
  138.   (lambda (pattern)
  139.     (and (pair? pattern)
  140.      (pair? (cdr pattern))
  141.      (memq (cadr pattern) syms)
  142.      (or (null? (cddr pattern))
  143.          (syntax-error "segment matching not implemented" pattern)))))
  144.  
  145. (define zero-or-more? (check-cadr `(* ,(string->symbol "..."))))
  146. (define at-least-one? (check-cadr '(+)))
  147.