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 / REWRITE.SCM < prev    next >
Text File  |  1990-02-10  |  4KB  |  143 lines
  1. ; Rewrite-rule compiler (a.k.a. "extend-syntax")
  2.  
  3. ; Example:
  4. ;
  5. ; (define-syntax or
  6. ;   (syntax-rules ()    ;Note that OR must *not* appear in this list!
  7. ;     ((or) => #f)
  8. ;     ((or e) => e)
  9. ;     ((or e1 e +) => (let ((temp e1))
  10. ;                (if temp temp (or e +))))))
  11.  
  12. (define (r exp)                ;for testing
  13.   (rewrite-syntax-rules exp (lambda (x) x) eq?))
  14.  
  15. (define (rewrite-rewrite exp rename)
  16.   (process-rules (cddr exp) (cadr exp) rename))
  17.  
  18. (define (process-rules rules noise-words rename)
  19.   (let ((tail '-tail-))
  20.     `(,(rename 'macro)
  21.       (lambda (-input- -rename-)        ;Should be renamed...
  22.     (let ((,tail (cdr -input-)))
  23.       (cond ,@(map (lambda (rule)
  24.              (process-rule rule tail noise-words))
  25.                rules)
  26.         (else (error "use of macro doesn't match definition"
  27.                  -input-))))))))
  28.  
  29. (define (process-rule rule tail noise-words)
  30.   (if (or (not (= (length rule) 3))
  31.       (not (eq? (cadr rule) '=>)))
  32.       (error "ill-formed rule" rule))
  33.   (let ((pattern (car rule))
  34.     (template (caddr rule)))
  35.     (let ((env (process-pattern (cdr pattern) tail 0 noise-words)))
  36.       `(,(process-match tail (cdr pattern) noise-words)
  37.     (let* ,(map (lambda (z)
  38.               `(,(car z) ,(cadr z)))
  39.             env)
  40.       ,(process-template template env 0 noise-words))))))
  41.  
  42. (define (process-pattern pattern path rank noise-words)
  43.   (cond ((name? pattern)
  44.      (if (member pattern noise-words)
  45.          '()
  46.          (list (list pattern path rank))))
  47.     ((or (zero-or-more? pattern)
  48.          (at-least-one? pattern))
  49.      (let ((temp '-temp-))  ;Bug -- should gensym here!!
  50.        (cons `(,temp ,path)
  51.          (map (lambda (z)
  52.             `(,(car z)
  53.               (map (lambda (-input-)
  54.                  ,(cadr z))
  55.                ,temp)
  56.               ,(caddr z)))
  57.               (process-pattern (car pattern)
  58.                        '-input-
  59.                        (cons (cadr pattern) rank)
  60.                        noise-words)))))
  61.     ((pair? pattern)
  62.      (append (process-pattern (car pattern) `(car ,path) rank noise-words)
  63.          (process-pattern (cdr pattern) `(cdr ,path) rank noise-words)))
  64.     (else '())))
  65.  
  66. (define (process-template template env rank noise-words)
  67.   (cond ((name? template)
  68.      (if (member template noise-words)
  69.          `',template
  70.          (let ((probe (assq template env)))
  71.            (if probe
  72.            (if (equal? (caddr probe) rank)
  73.                template
  74.                (error "rank error" template rank))
  75.            `(-rename- ',template)))))
  76.     ((or (zero-or-more? template)
  77.          (at-least-one? template))
  78.      (let ((vars (free-template-vars (car template) env '())))
  79.        (if (null? vars)
  80.            (error "ill-formed template" template)
  81.            `(map (lambda ,vars
  82.                ,(process-template (car template)
  83.                       env
  84.                       (cons (cadr template) rank)
  85.                       noise-words))
  86.              ,@vars))))
  87.     ((pair? template)
  88.      `(cons ,(process-template (car template) env rank noise-words)
  89.         ,(process-template (cdr template) env rank noise-words)))
  90.     (else `',template)))
  91.  
  92. (define (free-template-vars template env free)
  93.   (cond ((name? template)
  94.      (if (and (assq template env)
  95.           (not (memq template free)))
  96.          (cons template free)
  97.          '()))
  98.     ((or (zero-or-more? template)
  99.          (at-least-one? template))
  100.      (free-template-vars (cadr template) env free))
  101.     ((pair? template)
  102.      (free-template-vars (car template) env
  103.                  (free-template-vars (cdr template) env free)))
  104.     (else free)))
  105.  
  106. (define (check-cadr sym)
  107.   (lambda (pattern)
  108.     (and (pair? pattern)
  109.      (pair? (cdr pattern))
  110.      (eq? (cadr pattern) sym)
  111.      (or (null? (cddr pattern))
  112.          (error "segment matching not implemented" pattern)))))
  113.  
  114. (define zero-or-more? (check-cadr '*))
  115. (define at-least-one? (check-cadr '+))
  116.  
  117. ; Support
  118.  
  119. (define (process-match input pattern noise-words)
  120.   (cond ((name? pattern)
  121.      (if (member pattern noise-words)
  122.          `(equal? ,input ',pattern)
  123.          `#t))
  124.     ((zero-or-more? pattern)
  125.      (process-list-match input (car pattern) noise-words))
  126.     ((at-least-one? pattern)
  127.      `(and (not (null? ,input))
  128.            ,(process-list-match input (car pattern) noise-words)))
  129.     ((pair? pattern)
  130.      `(let ((temp ,input))
  131.         (and (pair? temp)
  132.          ,(process-match `(car temp) (car pattern) noise-words)
  133.          ,(process-match `(cdr temp) (cdr pattern) noise-words))))
  134.     (else
  135.      `(equal? ,input ',pattern))))
  136.  
  137. (define (process-list-match input pattern noise-words)
  138.   `(let loop ((l ,input))
  139.      (or (null? l)
  140.      (and (pair? l)
  141.           ,(process-match '(car l) pattern noise-words)
  142.           (loop (cdr l))))))
  143.