1 ;;; calist.el --- Condition functions
3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
4 ;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
5 ;; Licensed to the Free Software Foundation.
7 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
8 ;; Keywords: condition, alist, tree
10 ;; This file is part of APEL (A Portable Emacs Library).
12 ;; This program is free software; you can redistribute it and/or
13 ;; modify it under the terms of the GNU General Public License as
14 ;; published by the Free Software Foundation; either version 2, or (at
15 ;; your option) any later version.
17 ;; This program is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
29 (eval-when-compile (require 'cl))
33 (defvar calist-package-alist nil)
34 (defvar calist-field-match-method-obarray nil)
36 (defun find-calist-package (name)
37 "Return a calist-package by NAME."
38 (cdr (assq name calist-package-alist)))
40 (defun define-calist-field-match-method (field-type function)
41 "Set field-match-method for FIELD-TYPE to FUNCTION."
42 (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
45 (defun use-calist-package (name)
46 "Make the symbols of package NAME accessible in the current package."
47 (mapatoms (lambda (sym)
48 (if (intern-soft (symbol-name sym)
49 calist-field-match-method-obarray)
50 (signal 'conflict-of-calist-symbol
51 (list (format "Conflict of symbol %s" sym)))
53 (define-calist-field-match-method
54 sym (symbol-function sym))
56 (find-calist-package name)))
58 (defun make-calist-package (name &optional use)
59 "Create a new calist-package."
60 (let ((calist-field-match-method-obarray (make-vector 7 0)))
61 (set-alist 'calist-package-alist name
62 calist-field-match-method-obarray)
63 (use-calist-package (or use 'standard))
64 calist-field-match-method-obarray))
66 (defun in-calist-package (name)
67 "Set the current calist-package to a new or existing calist-package."
68 (setq calist-field-match-method-obarray
69 (or (find-calist-package name)
70 (make-calist-package name))))
72 (in-calist-package 'standard)
74 (defun calist-default-field-match-method (calist field-type field-value)
75 (let ((s-field (assoc field-type calist)))
77 (cons (cons field-type field-value) calist)
81 ((equal (cdr s-field) field-value)
84 (define-calist-field-match-method t (function calist-default-field-match-method))
86 (defsubst calist-field-match-method (field-type)
88 (or (intern-soft (if (symbolp field-type)
89 (symbol-name field-type)
91 calist-field-match-method-obarray)
92 (intern-soft "t" calist-field-match-method-obarray))))
94 (defsubst calist-field-match (calist field-type field-value)
95 (funcall (calist-field-match-method field-type)
96 calist field-type field-value))
98 (defun ctree-match-calist (rule-tree alist)
99 "Return matched condition-alist if ALIST matches RULE-TREE."
102 (let ((type (car rule-tree))
103 (choices (cdr rule-tree))
107 (let* ((choice (car choices))
108 (choice-value (car choice)))
109 (if (eq choice-value t)
110 (setq default choice)
111 (let ((ret-alist (calist-field-match alist type (car choice))))
115 (ctree-match-calist (cdr choice) ret-alist)
118 (setq choices (cdr choices)))
120 (let ((ret-alist (calist-field-match alist type t)))
123 (ctree-match-calist (cdr default) ret-alist)
127 (defun ctree-match-calist-partially (rule-tree alist)
128 "Return matched condition-alist if ALIST matches RULE-TREE."
131 (let ((type (car rule-tree))
132 (choices (cdr rule-tree))
136 (let* ((choice (car choices))
137 (choice-value (car choice)))
138 (if (eq choice-value t)
139 (setq default choice)
140 (let ((ret-alist (calist-field-match alist type (car choice))))
144 (ctree-match-calist-partially
145 (cdr choice) ret-alist)
148 (setq choices (cdr choices)))
150 (let ((ret-alist (calist-field-match alist type t)))
153 (ctree-match-calist-partially (cdr default) ret-alist)
155 (calist-field-match alist type t))
158 (defun ctree-find-calist (rule-tree alist &optional all)
159 "Return list of condition-alist which matches ALIST in RULE-TREE.
160 If optional argument ALL is specified, default rules are not ignored
161 even if other rules are matched for ALIST."
164 (let ((type (car rule-tree))
165 (choices (cdr rule-tree))
168 (let* ((choice (car choices))
169 (choice-value (car choice)))
170 (if (eq choice-value t)
171 (setq default choice)
172 (let ((ret-alist (calist-field-match alist type (car choice))))
175 (let ((ret (ctree-find-calist
176 (cdr choice) ret-alist all)))
178 (let ((elt (car ret)))
179 (or (member elt dest)
180 (setq dest (cons elt dest))
184 (or (member ret-alist dest)
185 (setq dest (cons ret-alist dest)))
187 (setq choices (cdr choices)))
188 (or (and (not all) dest)
190 (let ((ret-alist (calist-field-match alist type t)))
193 (let ((ret (ctree-find-calist
194 (cdr default) ret-alist all)))
196 (let ((elt (car ret)))
197 (or (member elt dest)
198 (setq dest (cons elt dest))
202 (or (member ret-alist dest)
203 (setq dest (cons ret-alist dest)))
208 (defun calist-to-ctree (calist)
209 "Convert condition-alist CALIST to condition-tree."
211 (let* ((cell (car calist)))
213 (list (cons (cdr cell)
214 (calist-to-ctree (cdr calist))
217 (defun ctree-add-calist-strictly (ctree calist)
218 "Add condition CALIST to condition-tree CTREE without default clause."
219 (cond ((null calist) ctree)
221 (calist-to-ctree calist)
224 (let* ((type (car ctree))
226 (ret (assoc type calist)))
230 (let ((cell (car values)))
231 (if (equal (car cell)(cdr ret))
234 (ctree-add-calist-strictly
236 (delete ret (copy-alist calist)))
238 (setq values (cdr values)))
239 (setcdr ctree (cons (cons (cdr ret)
241 (delete ret (copy-alist calist))))
246 (let ((cell (car values)))
248 (ctree-add-calist-strictly (cdr cell) calist))
250 (setq values (cdr values))))
254 (defun ctree-add-calist-with-default (ctree calist)
255 "Add condition CALIST to condition-tree CTREE with default clause."
256 (cond ((null calist) ctree)
258 (let* ((cell (car calist))
263 (cons value (calist-to-ctree (cdr calist)))))
266 (let* ((type (car ctree))
268 (ret (assoc type calist)))
272 (let ((cell (car values)))
273 (if (equal (car cell)(cdr ret))
276 (ctree-add-calist-with-default
278 (delete ret (copy-alist calist)))
280 (setq values (cdr values)))
281 (if (assq t (cdr ctree))
283 (cons (cons (cdr ret)
285 (delete ret (copy-alist calist))))
291 (delete ret (copy-alist calist))))
296 (let ((cell (car values)))
298 (ctree-add-calist-with-default (cdr cell) calist))
300 (setq values (cdr values)))
301 (let ((cell (assq t (cdr ctree))))
304 (ctree-add-calist-with-default (cdr cell)
306 (let ((elt (cons t (calist-to-ctree calist))))
307 (or (member elt (cdr ctree))
308 (setcdr ctree (cons elt (cdr ctree)))
314 (defun ctree-set-calist-strictly (ctree-var calist)
315 "Set condition CALIST in CTREE-VAR without default clause."
317 (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
319 (defun ctree-set-calist-with-default (ctree-var calist)
320 "Set condition CALIST to CTREE-VAR with default clause."
322 (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
329 (product-provide (provide 'calist) (require 'apel-ver))
331 ;;; calist.el ends here