sade/match.lisp at master · aartaka/sade · GitHub

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
;;;; match.lisp

(in-package #:sade)

(defgeneric %match (spec data bindings)
  (:method (spec data bindings)
    nil))

(defun match-symbol (spec data bindings)
  (cond
    ((eq spec '*)
     t)
    ((primitive-p spec)
     (eql data spec))
    ((gethash spec bindings)
     (%match (gethash spec bindings) data bindings))
    ((symbolp spec)
     (setf (gethash spec bindings) data))))

(defmethod %match ((spec symbol) data bindings)
  (match-symbol spec data bindings))

(defmethod %match ((spec integer) (data integer) bindings)
  (= spec data))

(defmethod %match ((spec list) (data list) bindings)
  (when (or (and (eq (car (last spec)) '**)
                 (>= (length data) (1- (length spec))))
            (= (length data) (length spec)))
    (loop for spec-elem in (if (eq (car (last spec)) '**)
                               (butlast spec)
                               spec)
          for data-elem in data
          for i from 0
          unless (%match spec-elem data-elem bindings)
            do (return nil)
          finally (return i))))

(defun match (spec data)
  (let ((bindings (make-hash-table :test 'equalp)))
    (values (%match spec data bindings)
            bindings)))