calist.el

   1 ;;; calist.el --- Condition functions
   2
   3 ;; Copyright (C) 1998 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: condition, alist, tree
   7
   8 ;; This file is part of APEL (A Portable Emacs Library).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28
  29 (defvar calist-field-match-method-obarray [nil])
  30
  31 (defun define-calist-field-match-method (field-type function)
  32   "Set field-match-method for FIELD-TYPE to FUNCTION."
  33   (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
  34         function))
  35
  36 (defun calist-default-field-match-method (calist field-type field-value)
  37   (let ((s-field (assoc field-type calist)))
  38     (cond ((null s-field)
  39            (cons (cons field-type field-value) calist)
  40            )
  41           ((eq field-value t)
  42            calist)
  43           ((equal (cdr s-field) field-value)
  44            calist))))
  45
  46 (defsubst calist-field-match-method (field-type)
  47   (condition-case nil
  48       (symbol-function
  49        (intern-soft
  50         (symbol-name field-type) calist-field-match-method-obarray))
  51     (error (symbol-function 'calist-default-field-match-method))
  52     ))
  53
  54 (defsubst calist-field-match (calist field-type field-value)
  55   (funcall (calist-field-match-method field-type)
  56            calist field-type field-value))
  57
  58 (defun ctree-match-calist (rule-tree alist)
  59   "Return matched condition-alist if ALIST matches RULE-TREE."
  60   (if (null rule-tree)
  61       alist
  62     (let ((type (car rule-tree))
  63           (choices (cdr rule-tree)))
  64       (catch 'tag
  65         (while choices
  66           (let* ((choice (car choices))
  67                  (ret-alist (calist-field-match alist type (car choice))))
  68             (if ret-alist
  69                 (throw 'tag
  70                        (if (cdr choice)
  71                            (ctree-match-calist (cdr choice) ret-alist)
  72                          ret-alist))))
  73           (setq choices (cdr choices))))
  74       )))
  75
  76 (defun calist-to-ctree (calist)
  77   "Convert condition-alist CALIST to condition-tree."
  78   (if calist
  79       (let* ((cell (car calist)))
  80         (cons (car cell)
  81               (list (cons (cdr cell)
  82                           (calist-to-ctree (cdr calist))
  83                           ))))))
  84
  85 (defun ctree-add-calist-strictly (ctree calist)
  86   "Add condition CALIST to condition-tree CTREE without default clause."
  87   (cond ((null calist) ctree)
  88         ((null ctree)
  89          (calist-to-ctree calist)
  90          )
  91         (t
  92          (let* ((type (car ctree))
  93                 (values (cdr ctree))
  94                 (ret (assoc type calist)))
  95            (if ret
  96                (catch 'tag
  97                  (while values
  98                    (let ((cell (car values)))
  99                      (if (equal (car cell)(cdr ret))
 100                          (throw 'tag
 101                                 (setcdr cell
 102                                         (ctree-add-calist-strictly
 103                                          (cdr cell)
 104                                          (delete ret (copy-alist calist)))
 105                                         ))))
 106                    (setq values (cdr values)))
 107                  (setcdr ctree (cons (cons (cdr ret)
 108                                            (calist-to-ctree
 109                                             (delete ret (copy-alist calist))))
 110                                      (cdr ctree)))
 111                  )
 112              (catch 'tag
 113                (while values
 114                  (let ((cell (car values)))
 115                    (setcdr cell
 116                            (ctree-add-calist-strictly (cdr cell) calist))
 117                    )
 118                  (setq values (cdr values))))
 119              )
 120            ctree))))
 121
 122 (defun ctree-add-calist-with-default (ctree calist)
 123   "Add condition CALIST to condition-tree CTREE with default clause."
 124   (cond ((null calist) ctree)
 125         ((null ctree)
 126          (let* ((cell (car calist))
 127                 (type (car cell))
 128                 (value (cdr cell)))
 129            (cons type
 130                  (list '(t)
 131                        (cons value (calist-to-ctree (cdr calist)))))
 132            ))
 133         (t
 134          (let* ((type (car ctree))
 135                 (values (cdr ctree))
 136                 (ret (assoc type calist)))
 137            (if ret
 138                (catch 'tag
 139                  (while values
 140                    (let ((cell (car values)))
 141                      (if (equal (car cell)(cdr ret))
 142                          (throw 'tag
 143                                 (setcdr cell
 144                                         (ctree-add-calist-with-default
 145                                          (cdr cell)
 146                                          (delete ret (copy-alist calist)))
 147                                         ))))
 148                    (setq values (cdr values)))
 149                  (setcdr ctree (list* '(t)
 150                                       (cons (cdr ret)
 151                                             (calist-to-ctree
 152                                              (delete ret (copy-alist calist))))
 153                                       (cdr ctree)))
 154                  )
 155              (catch 'tag
 156                (while values
 157                  (let ((cell (car values)))
 158                    (setcdr cell
 159                            (ctree-add-calist-with-default (cdr cell) calist))
 160                    )
 161                  (setq values (cdr values)))
 162                (let ((elt (cons t (calist-to-ctree calist))))
 163                  (or (member elt (cdr ctree))
 164                      (setcdr ctree (cons elt (cdr ctree)))
 165                      )))
 166              )
 167            ctree))))
 168
 169 (defun ctree-set-calist-strictly (ctree-var calist)
 170   "Set condition CALIST in CTREE-VAR without default clause."
 171   (set ctree-var
 172        (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
 173
 174 (defun ctree-set-calist-with-default (ctree-var calist)
 175   "Set condition CALIST to CTREE-VAR with default clause."
 176   (set ctree-var
 177        (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
 178
 179
 180 ;;; @ end
 181 ;;;
 182
 183 (provide 'calist)
 184
 185 ;;; calist.el ends here