Add calist.el.

diff --git a/APEL-ELS b/APEL-ELS
index 769b945..82fb729 100644 (file)
--- a/APEL-ELS
+++ b/APEL-ELS
@@ -1,9 +1,9 @@
 ;;; -*-Emacs-Lisp-*-
 ;;;
-;;; $Id: APEL-ELS,v 1.6 1997-11-06 15:47:18 morioka Exp $
+;;; $Id: APEL-ELS,v 1.7 1998-03-15 11:48:02 morioka Exp $
 ;;;
 
-(setq apel-modules '(alist atype
+(setq apel-modules '(alist calist atype
                           path-util filename install
                           std11 std11-parse
                           mule-caesar

diff --git a/calist.el b/calist.el
new file mode 100644 (file)
index 0000000..480b1ba
--- /dev/null
+++ b/calist.el
@@ -0,0 +1,172 @@
+;;; calist.el --- Condition functions
+
+;; Copyright (C) 1998 MORIOKA Tomohiko.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: condition, alist, tree
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(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)))
+      (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))))
+      )))
+
+(defun calist-to-ctree (calist)
+  "Convert condition-alist CALIST to condition-tree."
+  (if calist
+      (let* ((cell (car calist)))
+       (cons (car cell)
+             (list (cons (cdr cell)
+                         (calist-to-ctree (cdr calist))
+                         ))))))
+
+(defun ctree-add-calist-strictly (ctree calist)
+  "Add condition CALIST to condition-tree CTREE without default clause."
+  (cond ((null calist) ctree)
+       ((null ctree)
+        (calist-to-ctree calist)
+        )
+       (t
+        (let* ((type (car ctree))
+               (values (cdr ctree))
+               (ret (assoc type calist)))
+          (if ret
+              (catch 'tag
+                (while values
+                  (let ((cell (car values)))
+                    (if (equal (car cell)(cdr ret))
+                        (throw 'tag
+                               (setcdr cell
+                                       (ctree-add-calist-strictly
+                                        (cdr cell)
+                                        (delete ret (copy-alist calist)))
+                                       ))))
+                  (setq values (cdr values)))
+                (setcdr ctree (cons (cons (cdr ret)
+                                          (calist-to-ctree
+                                           (delete ret (copy-alist calist))))
+                                    (cdr ctree)))
+                )
+            (catch 'tag
+              (while values
+                (let ((cell (car values)))
+                  (setcdr cell
+                          (ctree-add-calist-strictly (cdr cell) calist))
+                  )
+                (setq values (cdr values))))
+            )
+          ctree))))
+
+(defun ctree-add-calist-with-default (ctree calist)
+  "Add condition CALIST to condition-tree CTREE with default clause."
+  (cond ((null calist) ctree)
+       ((null ctree)
+        (let* ((cell (car calist))
+               (type (car cell))
+               (value (cdr cell)))
+          (cons type
+                (list '(t)
+                      (cons value (calist-to-ctree (cdr calist)))))
+          ))
+       (t
+        (let* ((type (car ctree))
+               (values (cdr ctree))
+               (ret (assoc type calist)))
+          (if ret
+              (catch 'tag
+                (while values
+                  (let ((cell (car values)))
+                    (if (equal (car cell)(cdr ret))
+                        (throw 'tag
+                               (setcdr cell
+                                       (ctree-add-calist-with-default
+                                        (cdr cell)
+                                        (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)))
+                )
+            (catch 'tag
+              (while values
+                (let ((cell (car values)))
+                  (setcdr cell
+                          (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)))
+                    )))
+            )
+          ctree))))
+
+(defun ctree-set-calist-strictly (ctree-var calist)
+  "Set condition CALIST in CTREE-VAR without default clause."
+  (set ctree-var
+       (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
+
+(defun ctree-set-calist-with-default (ctree-var calist)
+  "Set condition CALIST to CTREE-VAR with default clause."
+  (set ctree-var
+       (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
+
+
+;;; @ end
+;;;
+
+(provide 'calist)
+
+;;; calist.el ends here