X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=calist.el;h=fbef6808a08863ff8d80b690c6e47d9d1592556e;hb=856f094dabc99315a46caf8865beee174228f8af;hp=3c27b9f81d96c22f5476efd9911949d4c9a65574;hpb=59423fabcdc1ba9f907842d612c7babde6563651;p=elisp%2Fapel.git

diff --git a/calist.el b/calist.el
index 3c27b9f..fbef680 100644
--- a/calist.el
+++ b/calist.el
@@ -1,8 +1,10 @@
 ;;; calist.el --- Condition functions
 
-;; Copyright (C) 1998 MORIOKA Tomohiko.
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
 
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
 ;; Keywords: condition, alist, tree
 
 ;; This file is part of APEL (A Portable Emacs Library).
@@ -26,13 +28,49 @@
 
 (eval-when-compile (require 'cl))
 
-(defvar calist-field-match-method-obarray [nil])
+(require 'alist)
+
+(defvar calist-package-alist nil)
+(defvar calist-field-match-method-obarray nil)
+
+(defun find-calist-package (name)
+  "Return a calist-package by NAME."
+  (cdr (assq name calist-package-alist)))
 
 (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 use-calist-package (name)
+  "Make the symbols of package NAME accessible in the current package."
+  (mapatoms (lambda (sym)
+	      (if (intern-soft (symbol-name sym)
+			       calist-field-match-method-obarray)
+		  (signal 'conflict-of-calist-symbol
+			  (list (format "Conflict of symbol %s")))
+		(if (fboundp sym)
+		    (define-calist-field-match-method
+		      sym (symbol-function sym))
+		  )))
+	    (find-calist-package name)))
+
+(defun make-calist-package (name &optional use)
+  "Create a new calist-package."
+  (let ((calist-field-match-method-obarray (make-vector 7 0)))
+    (set-alist 'calist-package-alist name
+	       calist-field-match-method-obarray)
+    (use-calist-package (or use 'standard))
+    calist-field-match-method-obarray))
+
+(defun in-calist-package (name)
+  "Set the current calist-package to a new or existing calist-package."
+  (setq calist-field-match-method-obarray
+	(or (find-calist-package name)
+	    (make-calist-package name))))
+
+(in-calist-package 'standard)
+
 (defun calist-default-field-match-method (calist field-type field-value)
   (let ((s-field (assoc field-type calist)))
     (cond ((null s-field)
@@ -43,13 +81,15 @@
 	  ((equal (cdr s-field) field-value)
 	   calist))))
 
+(define-calist-field-match-method t (function calist-default-field-match-method))
+
 (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))
-    ))
+  (symbol-function
+   (or (intern-soft (if (symbolp field-type)
+			(symbol-name field-type)
+		      field-type)
+		    calist-field-match-method-obarray)
+       (intern-soft "t" calist-field-match-method-obarray))))
 
 (defsubst calist-field-match (calist field-type field-value)
   (funcall (calist-field-match-method field-type)
@@ -60,18 +100,110 @@
   (if (null rule-tree)
       alist
     (let ((type (car rule-tree))
-	  (choices (cdr rule-tree)))
+	  (choices (cdr rule-tree))
+	  default)
       (catch 'tag
 	(while choices
 	  (let* ((choice (car choices))
-		 (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))))
-      )))
+		 (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))
+			  ))
+		    (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."
@@ -127,7 +259,7 @@
 		(type (car cell))
 		(value (cdr cell)))
 	   (cons type
-		 (list '(t)
+		 (list (list t)
 		       (cons value (calist-to-ctree (cdr calist)))))
 	   ))
 	(t
@@ -146,12 +278,19 @@
 					 (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)))
@@ -159,10 +298,16 @@
 			   (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))))
 
@@ -180,6 +325,7 @@
 ;;; @ end
 ;;;
 
-(provide 'calist)
+(require 'product)
+(product-provide (provide 'calist) (require 'apel-ver))
 
 ;;; calist.el ends here