(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))
- (choices (cdr rule-tree))
- (k-value (assoc type alist)))
+ (let ((type (car rule-tree))
+ (choices (cdr rule-tree))
+ default)
(catch 'tag
(while choices
- (let ((choice (car choices)))
- (cond ((null k-value)
- (throw 'tag
- (if (cdr choice)
- (ctree-match-calist
- (cdr choice)
- (cons (cons type (car choice)) alist))
- (cons (cons type (car choice)) alist)
- )))
- ((eq (car choice) t)
- (throw 'tag
- (if (cdr k-value)
- (ctree-match-calist (cdr choice) alist)
- alist)
- ))
- ((equal (car choice) (cdr k-value))
- (throw 'tag
- (if (cdr choice)
- (ctree-match-calist (cdr choice) alist)
- alist)
+ (let* ((choice (car choices))
+ (choice-value (car choice)))
+ (if (eq choice-value t)
+ (setq default choice)
+ (let ((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)))
+ (if default
+ (let ((ret-alist (calist-field-match alist type t)))
+ (if ret-alist
+ (if (cdr default)
+ (ctree-match-calist (cdr default) ret-alist)
+ ret-alist))))
+ ))))
+
+(defun ctree-match-calist-partially (rule-tree alist)
+ "Return matched condition-alist if ALIST matches RULE-TREE."
+ (if (null rule-tree)
+ alist
+ (let ((type (car rule-tree))
+ (choices (cdr rule-tree))
+ default)
+ (catch 'tag
+ (while choices
+ (let* ((choice (car choices))
+ (choice-value (car choice)))
+ (if (eq choice-value t)
+ (setq default choice)
+ (let ((ret-alist (calist-field-match alist type (car choice))))
+ (if ret-alist
+ (throw 'tag
+ (if (cdr choice)
+ (ctree-match-calist-partially
+ (cdr choice) ret-alist)
+ ret-alist))
+ ))))
+ (setq choices (cdr choices)))
+ (if default
+ (let ((ret-alist (calist-field-match alist type t)))
+ (if ret-alist
+ (if (cdr default)
+ (ctree-match-calist-partially (cdr default) ret-alist)
+ ret-alist)))
+ (calist-field-match alist type t))
+ ))))
+
+(defun ctree-find-calist (rule-tree alist &optional all)
+ "Return list of condition-alist which matches ALIST in RULE-TREE.
+If optional argument ALL is specified, default rules are not ignored
+even if other rules are matched for ALIST."
+ (if (null rule-tree)
+ (list alist)
+ (let ((type (car rule-tree))
+ (choices (cdr rule-tree))
+ default dest)
+ (while choices
+ (let* ((choice (car choices))
+ (choice-value (car choice)))
+ (if (eq choice-value t)
+ (setq default choice)
+ (let ((ret-alist (calist-field-match alist type (car choice))))
+ (if ret-alist
+ (if (cdr choice)
+ (let ((ret (ctree-find-calist
+ (cdr choice) ret-alist all)))
+ (while ret
+ (let ((elt (car ret)))
+ (or (member elt dest)
+ (setq dest (cons elt dest))
+ ))
+ (setq ret (cdr ret))
))
- ))
- (setq choices (cdr choices))))
- )))
+ (or (member ret-alist dest)
+ (setq dest (cons ret-alist dest)))
+ )))))
+ (setq choices (cdr choices)))
+ (or (and (not all) dest)
+ (if default
+ (let ((ret-alist (calist-field-match alist type t)))
+ (if ret-alist
+ (if (cdr default)
+ (let ((ret (ctree-find-calist
+ (cdr default) ret-alist all)))
+ (while ret
+ (let ((elt (car ret)))
+ (or (member elt dest)
+ (setq dest (cons elt dest))
+ ))
+ (setq ret (cdr ret))
+ ))
+ (or (member ret-alist dest)
+ (setq dest (cons ret-alist dest)))
+ ))))
+ )
+ dest)))
(defun calist-to-ctree (calist)
"Convert condition-alist CALIST to condition-tree."
(type (car cell))
(value (cdr cell)))
(cons type
- (list '(t)
+ (list (list t)
(cons value (calist-to-ctree (cdr calist)))))
))
(t
(delete ret (copy-alist calist)))
))))
(setq values (cdr values)))
- (setcdr ctree (list* '(t)
- (cons (cdr ret)
- (calist-to-ctree
- (delete ret (copy-alist calist))))
- (cdr ctree)))
- )
+ (if (assq t (cdr ctree))
+ (setcdr ctree
+ (cons (cons (cdr ret)
+ (calist-to-ctree
+ (delete ret (copy-alist calist))))
+ (cdr ctree)))
+ (setcdr ctree
+ (list* (list t)
+ (cons (cdr ret)
+ (calist-to-ctree
+ (delete ret (copy-alist calist))))
+ (cdr ctree)))
+ ))
(catch 'tag
(while values
(let ((cell (car values)))
(ctree-add-calist-with-default (cdr cell) calist))
)
(setq values (cdr values)))
- (let ((elt (cons t (calist-to-ctree calist))))
- (or (member elt (cdr ctree))
- (setcdr ctree (cons elt (cdr ctree)))
- )))
+ (let ((cell (assq t (cdr ctree))))
+ (if cell
+ (setcdr cell
+ (ctree-add-calist-with-default (cdr cell)
+ calist))
+ (let ((elt (cons t (calist-to-ctree calist))))
+ (or (member elt (cdr ctree))
+ (setcdr ctree (cons elt (cdr ctree)))
+ ))
+ )))
)
ctree))))