* poem-om.el (find-file-noselect-as-raw-text-CRLF): New function. It is an

[elisp/apel.git] / calist.el

diff --git a/calist.el b/calist.el
index 0d47b82..504476a 100644 (file)
--- a/calist.el
+++ b/calist.el
@@ -84,9 +84,42 @@
                    ret-alist))))
        ))))
 
-(defun ctree-match-calist-all (rule-tree 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))
@@ -99,21 +132,38 @@
            (let ((ret-alist (calist-field-match alist type (car choice))))
              (if ret-alist
                  (if (cdr choice)
-                     (setq dest
-                           (append
-                            (ctree-match-calist-all (cdr choice) ret-alist)
-                            dest))
-                   (setq dest (cons ret-alist dest))
+                     (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 dest
+      (or (and (not all) dest)
          (if default
              (let ((ret-alist (calist-field-match alist type t)))
                (if ret-alist
                    (if (cdr default)
-                       (ctree-match-calist-all (cdr default) ret-alist)
-                     (list ret-alist)
-                     ))))))))
+                       (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."
@@ -169,7 +219,7 @@
                (type (car cell))
                (value (cdr cell)))
           (cons type
-                (list '(t)
+                (list (list t)
                       (cons value (calist-to-ctree (cdr calist)))))
           ))
        (t
@@ -188,12 +238,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)))
@@ -201,10 +258,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))))