1 ;;; calist.el --- Condition functions
3 ;; Copyright (C) 1998 MORIOKA Tomohiko.
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Keywords: condition, alist, tree
8 ;; This file is part of APEL (A Portable Emacs Library).
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 (eval-when-compile (require 'cl))
29 (defvar calist-field-match-method-obarray [nil])
31 (defun define-calist-field-match-method (field-type function)
32 "Set field-match-method for FIELD-TYPE to FUNCTION."
33 (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
36 (defun calist-default-field-match-method (calist field-type field-value)
37 (let ((s-field (assoc field-type calist)))
39 (cons (cons field-type field-value) calist)
43 ((equal (cdr s-field) field-value)
46 (defsubst calist-field-match-method (field-type)
50 (symbol-name field-type) calist-field-match-method-obarray))
51 (error (symbol-function 'calist-default-field-match-method))
54 (defsubst calist-field-match (calist field-type field-value)
55 (funcall (calist-field-match-method field-type)
56 calist field-type field-value))
58 (defun ctree-match-calist (rule-tree alist)
59 "Return matched condition-alist if ALIST matches RULE-TREE."
62 (let ((type (car rule-tree))
63 (choices (cdr rule-tree))
67 (let* ((choice (car choices))
68 (choice-value (car choice)))
69 (if (eq choice-value t)
71 (let ((ret-alist (calist-field-match alist type (car choice))))
75 (ctree-match-calist (cdr choice) ret-alist)
78 (setq choices (cdr choices)))
80 (let ((ret-alist (calist-field-match alist type t)))
83 (ctree-match-calist (cdr default) ret-alist)
87 (defun ctree-find-calist (rule-tree alist &optional all)
88 "Return list of condition-alist which matches ALIST in RULE-TREE."
91 (let ((type (car rule-tree))
92 (choices (cdr rule-tree))
95 (let* ((choice (car choices))
96 (choice-value (car choice)))
97 (if (eq choice-value t)
99 (let ((ret-alist (calist-field-match alist type (car choice))))
103 (append (ctree-find-calist
104 (cdr choice) ret-alist all)
106 (setq dest (cons ret-alist dest))
108 (setq choices (cdr choices)))
109 (or (and (not all) dest)
111 (let ((ret-alist (calist-field-match alist type t)))
115 (append (ctree-find-calist
116 (cdr default) ret-alist all)
118 (setq dest (cons ret-alist dest))
123 (defun calist-to-ctree (calist)
124 "Convert condition-alist CALIST to condition-tree."
126 (let* ((cell (car calist)))
128 (list (cons (cdr cell)
129 (calist-to-ctree (cdr calist))
132 (defun ctree-add-calist-strictly (ctree calist)
133 "Add condition CALIST to condition-tree CTREE without default clause."
134 (cond ((null calist) ctree)
136 (calist-to-ctree calist)
139 (let* ((type (car ctree))
141 (ret (assoc type calist)))
145 (let ((cell (car values)))
146 (if (equal (car cell)(cdr ret))
149 (ctree-add-calist-strictly
151 (delete ret (copy-alist calist)))
153 (setq values (cdr values)))
154 (setcdr ctree (cons (cons (cdr ret)
156 (delete ret (copy-alist calist))))
161 (let ((cell (car values)))
163 (ctree-add-calist-strictly (cdr cell) calist))
165 (setq values (cdr values))))
169 (defun ctree-add-calist-with-default (ctree calist)
170 "Add condition CALIST to condition-tree CTREE with default clause."
171 (cond ((null calist) ctree)
173 (let* ((cell (car calist))
178 (cons value (calist-to-ctree (cdr calist)))))
181 (let* ((type (car ctree))
183 (ret (assoc type calist)))
187 (let ((cell (car values)))
188 (if (equal (car cell)(cdr ret))
191 (ctree-add-calist-with-default
193 (delete ret (copy-alist calist)))
195 (setq values (cdr values)))
196 (setcdr ctree (list* '(t)
199 (delete ret (copy-alist calist))))
204 (let ((cell (car values)))
206 (ctree-add-calist-with-default (cdr cell) calist))
208 (setq values (cdr values)))
209 (let ((elt (cons t (calist-to-ctree calist))))
210 (or (member elt (cdr ctree))
211 (setcdr ctree (cons elt (cdr ctree)))
216 (defun ctree-set-calist-strictly (ctree-var calist)
217 "Set condition CALIST in CTREE-VAR without default clause."
219 (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
221 (defun ctree-set-calist-with-default (ctree-var calist)
222 "Set condition CALIST to CTREE-VAR with default clause."
224 (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
232 ;;; calist.el ends here