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 / pmlook.scm < prev    next >
Text File  |  1999-01-02  |  3KB  |  82 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pmlook.scm,v 1.9 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: Lookup
  23. ;;; package: (compiler pattern-matcher/lookup)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define pattern-variable-tag
  28.   (intern "#[(compiler pattern-matcher/lookup)pattern-variable]"))
  29.  
  30. ;;; PATTERN-LOOKUP returns either false or a pair whose car is the
  31. ;;; item matched and whose cdr is the list of variable values.  Use
  32. ;;; PATTERN-VARIABLES to get a list of names that is in the same order
  33. ;;; as the list of values.
  34.  
  35. (define (pattern-lookup entries instance)
  36.   (define (lookup-loop entries values bindings)
  37.     (define (match pattern instance)
  38.       (if (pair? pattern)
  39.       (if (eq? (car pattern) pattern-variable-tag)
  40.           (let ((entry (memq (cdr pattern) bindings)))
  41.         (if (not entry)
  42.             (begin (set! bindings (cons (cdr pattern) bindings))
  43.                (set! values (cons instance values))
  44.                true)
  45.             (eqv? instance
  46.               (list-ref values (- (length bindings)
  47.                           (length entry))))))
  48.           (and (pair? instance)
  49.            (match (car pattern) (car instance))
  50.            (match (cdr pattern) (cdr instance))))
  51.       (eqv? pattern instance)))
  52.  
  53.     (and (not (null? entries))
  54.      (or (and (match (caar entries) instance)
  55.           (pattern-lookup/bind (cdar entries) values))
  56.          (lookup-loop (cdr entries) '() '()))))
  57.   (lookup-loop entries '() '()))
  58.  
  59. (define-integrable (pattern-lookup/bind binder values)
  60.   (apply binder values))
  61.  
  62. (define (pattern-variables pattern)
  63.   (let ((variables '()))
  64.     (define (loop pattern)
  65.       (if (pair? pattern)
  66.       (if (eq? (car pattern) pattern-variable-tag)
  67.           (if (not (memq (cdr pattern) variables))
  68.           (set! variables (cons (cdr pattern) variables)))
  69.           (begin (loop (car pattern))
  70.              (loop (cdr pattern))))))
  71.     (loop pattern)
  72.     variables))
  73.  
  74. (define-integrable (make-pattern-variable name)
  75.   (cons pattern-variable-tag name))
  76.  
  77. (define (pattern-variable? object)
  78.   (and (pair? object)
  79.        (eq? (car object) pattern-variable-tag)))
  80.  
  81. (define-integrable (pattern-variable-name var)
  82.   (cdr var))