git @ Cat's Eye Technologies Treacle / master src / match.scm
master

Tree @master (Download .tar.gz)

match.scm @master — raw · history · blame 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
;
; Support for matching context-rewriting patterns (names, wildcards, holes)
; Chris Pressey, March 2008
;

; SPDX-FileCopyrightText: (c) 2008-2024 Chris Pressey, Cat's Eye Technologies
; This file is distributed under a 2-clause BSD license.  For more information see:
; SPDX-License-Identifier: LicenseRef-BSD-2-Clause-X-Treacle

;
; Shorthand for common usage of match.
;
(define toplevel-match
  (lambda (subject pattern)
    (match subject subject pattern (mk-empty-unifier) (mk-base-index))))

;
; Attempt to find a unifier (list of substitutions) which makes
; the given pattern equal to the given term, and return it.
; Return #f if the pattern does not match.
;
; Note that match, upon matching a hole, calls search-match.
; This is mutually recursive, since search-match also calls match.
;
(define match
  (lambda (subject term pattern unifier index)
    (cond ((is-wildcard? pattern)
            unifier)
          ((is-named? pattern)
            (let* ((name     (get-name pattern))
                   (subpat   (get-named-subpat pattern))
                   (submatch (match subject term subpat unifier index)))
              (cond (submatch
                      ; note that we pass the whole subject here
                      (bind-name subject (reverse index) name submatch))
                    (else
                      #f))))
          ((is-hole? pattern)
            (let* ((order  (get-hole-order pattern))
                   (subpat (get-hole-subpat pattern)))
              (cond ((eq? order 'innermost)
                      (search-match-innermost subject term subpat unifier index))
                    ((eq? order 'outermost)
                      (search-match-outermost subject term subpat unifier index))
                    (else
                      #f))))
          ((and (list? term) (list? pattern))
            (match-lists subject term pattern unifier (descend-index index)))
          ((eqv? term pattern)
            unifier)
          (else
            #f))))

;
; Helper function for match.
; Given a term and a pattern, where we know both are lists,
; fold over both of them, matching all the corresponding elements.
;
(define match-lists
  (lambda (subject term pattern unifier index)
    (cond ((and (null? term) (null? pattern))  ; end of both
            unifier)
          ((or (null? term) (null? pattern))   ; end of one but not the other
            #f)
          (else
            (let ((new-unifier (match subject (car term) (car pattern) unifier index))
                  (new-index   (next-index index)))
              (if new-unifier
                (match-lists subject (cdr term) (cdr pattern) new-unifier new-index)
                #f))))))

;
; Match the given pattern to any subterm of the given term, if possible.
; Give priority to the leftmost outermost subterm that matches.
; Returns a new unifier, or #f.
;
; While searching, this tracks a term index which points to the subterm
; that matches.  We pass this back in the returned unifier.
;
(define search-match-outermost
  (lambda (subject term pattern unifier index)
    (let* ((new-unifier (match subject term pattern unifier index)))
      (cond (new-unifier
              new-unifier)
            ((list? term)
              (search-match-list-outermost subject term pattern unifier (descend-index index)))
            (else
              #f)))))

;
; Helper function.  Try to match the given pattern to each term in the
; given list, left to right.  Return new unifier on first successful
; match, or #f is there is none.
;
(define search-match-list-outermost
  (lambda (subject terms pattern unifier index)
    (cond ((null? terms)
            #f)
          (else
            (let* ((new-unifier (search-match-outermost subject (car terms) pattern unifier index))
                   (new-index   (next-index index)))
              (if new-unifier
                new-unifier
                (search-match-list-outermost subject (cdr terms) pattern unifier new-index)))))))

;
; Match the given pattern to any subterm of the given term, if possible.
; Give priority to the leftmost innermost subterm that matches.
; Returns a new unifier, or #f.
;
; While searching, this tracks a term index which points to the subterm
; that matches.  We return this in the returned unifier.
;
(define search-match-innermost
  (lambda (subject term pattern unifier index)
    (cond ((list? term)
            (let* ((new-unifier (search-match-list-innermost subject term pattern unifier (descend-index index))))
              (if new-unifier
                new-unifier
                (match subject term pattern unifier index))))
          (else
            (match subject term pattern unifier index)))))

;
; Helper function.  Try to match the given pattern to each term in the
; given list, left to right.  Return new unifier on first successful
; match, or #f is there is none.
;
(define search-match-list-innermost
  (lambda (subject terms pattern unifier index)
    (cond ((null? terms)
            #f)
          (else
            (let* ((new-unifier (search-match-innermost subject (car terms) pattern unifier index))
                   (new-index   (next-index index)))
              (if new-unifier
                new-unifier
                (search-match-list-innermost subject (cdr terms) pattern unifier new-index)))))))