home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / base / pmpars.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  142 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pmpars.scm,v 1.4 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Very Simple Pattern Matcher: Parser
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;; PARSE-RULE and RULE-RESULT-EXPRESSION are used together to parse
  27. ;;; pattern/body definitions, producing Scheme code which can then be
  28. ;;; compiled.
  29.  
  30. ;;; PARSE-RULE, given a PATTERN and a BODY, returns: (1) a pattern for
  31. ;;; use with the matcher; (2) the variables in the pattern, in the
  32. ;;; order that the matcher will produce their corresponding values;
  33. ;;; (3) a list of qualifier expressions; and (4) a list of actions
  34. ;;; which should be executed sequentially when the rule fires.
  35.  
  36. ;;; RULE-RESULT-EXPRESSION is used to generate a lambda expression
  37. ;;; which, when passed the values resulting from the match as its
  38. ;;; arguments, will return either false, indicating that the
  39. ;;; qualifications failed, or the result of the body.
  40.  
  41. (define (parse-rule pattern body receiver)
  42.   (extract-variables
  43.    pattern
  44.    (lambda (pattern variables)
  45.      (extract-qualifier
  46.       body
  47.       (lambda (qualifiers actions)
  48.     (let ((names (pattern-variables pattern)))
  49.       (receiver pattern
  50.             (reorder-variables variables names)
  51.             qualifiers
  52.             actions)))))))
  53.  
  54. (define (extract-variables pattern receiver)
  55.   (if (pair? pattern)
  56.       (if (memq (car pattern) '(? ?@))
  57.       (receiver (make-pattern-variable (cadr pattern))
  58.             (list (cons (cadr pattern)
  59.                 (if (null? (cddr pattern))
  60.                     '()
  61.                     (list (cons (car pattern)
  62.                         (cddr pattern)))))))
  63.       (extract-variables (car pattern)
  64.         (lambda (car-pattern car-variables)
  65.           (extract-variables (cdr pattern)
  66.         (lambda (cdr-pattern cdr-variables)
  67.           (receiver (cons car-pattern cdr-pattern)
  68.                 (merge-variables-lists car-variables
  69.                            cdr-variables)))))))
  70.       (receiver pattern '())))
  71.  
  72. (define (merge-variables-lists x y)
  73.   (cond ((null? x) y)
  74.     ((null? y) x)
  75.     (else
  76.      (let ((entry (assq (caar x) y)))
  77.        (if entry
  78.            (cons (append! (car x) (cdr entry))
  79.              (merge-variables-lists (cdr x)
  80.                         (delq! entry y)))
  81.            (cons (car x)
  82.              (merge-variables-lists (cdr x)
  83.                         y)))))))
  84.  
  85. (define (extract-qualifier body receiver)
  86.   (if (and (pair? (car body))
  87.        (eq? (caar body) 'QUALIFIER))
  88.       (receiver (cdar body) (cdr body))
  89.       (receiver '() body)))
  90.  
  91. (define (reorder-variables variables names)
  92.   (map (lambda (name) (assq name variables))
  93.        names))
  94.  
  95. (define (rule-result-expression variables qualifiers body)
  96.   (let ((body `(lambda () ,body)))
  97.     (process-transformations variables
  98.       (lambda (outer-vars inner-vars xforms xqualifiers)
  99.     (if (null? inner-vars)
  100.         `(lambda ,outer-vars
  101.            ,(if (null? qualifiers)
  102.             body
  103.             `(and ,@qualifiers ,body)))
  104.         `(lambda ,outer-vars
  105.            (let ,(map list inner-vars xforms)
  106.          (and ,@xqualifiers
  107.               ,@qualifiers
  108.               ,body))))))))
  109.  
  110. (define (process-transformations variables receiver)
  111.   (if (null? variables)
  112.       (receiver '() '() '() '())
  113.       (process-transformations (cdr variables)
  114.     (lambda (outer inner xform qual)
  115.       (let ((name (caar variables))
  116.         (variable (cdar variables)))
  117.         (cond ((null? variable)
  118.            (receiver (cons name outer)
  119.                  inner
  120.                  xform
  121.                  qual))
  122.           ((not (null? (cdr variable)))
  123.            (error "process-trasformations: Multiple qualifiers"
  124.               (car variables)))
  125.           (else
  126.            (let ((var (car variable)))
  127.              (define (handle-xform rename)
  128.                (if (eq? (car var) '?)
  129.                (receiver (cons rename outer)
  130.                      (cons name inner)
  131.                      (cons `(,(cadr var) ,rename)
  132.                        xform)
  133.                      (cons name qual))
  134.                (receiver (cons rename outer)
  135.                      (cons name inner)
  136.                      (cons `(MAP ,(cadr var) ,rename)
  137.                        xform)
  138.                      (cons `(APPLY BOOLEAN/AND ,name) qual))))
  139.              (handle-xform
  140.               (if (null? (cddr var))
  141.               name
  142.               (caddr var)))))))))))