From 6f2fe18628d85723a1ff1a9543fc744e8e332c3d Mon Sep 17 00:00:00 2001
From: morioka <morioka>
Date: Sun, 15 Mar 1998 11:48:04 +0000
Subject: [PATCH] Add calist.el.

---
 APEL-ELS  |    4 +-
 calist.el |  172 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 174 insertions(+), 2 deletions(-)
 create mode 100644 calist.el

diff --git a/APEL-ELS b/APEL-ELS
index 769b945..82fb729 100644
--- 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
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
-- 
1.7.10.4