update.

[elisp/apel.git] / calist.el

diff --git a/calist.el b/calist.el
index 480b1ba..3c27b9f 100644 (file)
--- a/calist.el
+++ b/calist.el
@@ -26,38 +26,51 @@
 
 (eval-when-compile (require 'cl))
 
+(defvar calist-field-match-method-obarray [nil])
+
+(defun define-calist-field-match-method (field-type function)
+  "Set field-match-method for FIELD-TYPE to FUNCTION."
+  (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
+       function))
+
+(defun calist-default-field-match-method (calist field-type field-value)
+  (let ((s-field (assoc field-type calist)))
+    (cond ((null s-field)
+          (cons (cons field-type field-value) calist)
+          )
+         ((eq field-value t)
+          calist)
+         ((equal (cdr s-field) field-value)
+          calist))))
+
+(defsubst calist-field-match-method (field-type)
+  (condition-case nil
+      (symbol-function
+       (intern-soft
+       (symbol-name field-type) calist-field-match-method-obarray))
+    (error (symbol-function 'calist-default-field-match-method))
+    ))
+
+(defsubst calist-field-match (calist field-type field-value)
+  (funcall (calist-field-match-method field-type)
+          calist field-type field-value))
+
 (defun ctree-match-calist (rule-tree alist)
   "Return matched condition-alist if ALIST matches RULE-TREE."
   (if (null rule-tree)
       alist
-    (let* ((type (car rule-tree))
-          (values (cdr rule-tree))
-          (k-value (assoc type alist)))
+    (let ((type (car rule-tree))
+         (choices (cdr rule-tree)))
       (catch 'tag
-       (while values
-         (let ((cell (car values)))
-           (cond ((null k-value)
-                  (throw 'tag
-                         (if (cdr cell)
-                             (ctree-match-calist
-                              (cdr cell)
-                              (cons (cons type (car cell)) alist))
-                           (cons (cons type (car cell)) alist)
-                           )))
-                 ((eq (car cell) t)
-                  (throw 'tag
-                         (if (cdr k-value)
-                             (ctree-match-calist (cdr cell) alist)
-                           alist)
-                         ))
-                 ((equal (car cell) (cdr k-value))
-                  (throw 'tag
-                         (if (cdr cell)
-                             (ctree-match-calist (cdr cell) alist)
-                           alist)
-                         ))
-                 ))
-         (setq values (cdr values))))
+       (while choices
+         (let* ((choice (car choices))
+                (ret-alist (calist-field-match alist type (car choice))))
+           (if ret-alist
+               (throw 'tag
+                      (if (cdr choice)
+                          (ctree-match-calist (cdr choice) ret-alist)
+                        ret-alist))))
+         (setq choices (cdr choices))))
       )))
 
 (defun calist-to-ctree (calist)