calist.el

   1 ;;; calist.el --- Condition functions
   2
   3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
   5 ;; Licensed to the Free Software Foundation.
   6
   7 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   8 ;; Keywords: condition, alist, tree
   9
  10 ;; This file is part of APEL (A Portable Emacs Library).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'alist)
  32
  33 (defvar calist-package-alist nil)
  34 (defvar calist-field-match-method-obarray nil)
  35
  36 (defun make-calist-package (name)
  37   "Create a new calist-package."
  38   (let ((p (make-vector 7 0)))
  39     (set-alist 'calist-package-alist name p)
  40     p))
  41
  42 (defun find-calist-package (name)
  43   "Return a calist-package by NAME."
  44   (cdr (assq name calist-package-alist)))
  45
  46 (defun in-calist-package (name)
  47   "Set the current calist-package to a new or existing calist-package."
  48   (setq calist-field-match-method-obarray
  49         (or (find-calist-package name)
  50             (make-calist-package name))))
  51
  52 (in-calist-package 'standard)
  53
  54 (defun define-calist-field-match-method (field-type function)
  55   "Set field-match-method for FIELD-TYPE to FUNCTION."
  56   (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
  57         function))
  58
  59 (defun calist-default-field-match-method (calist field-type field-value)
  60   (let ((s-field (assoc field-type calist)))
  61     (cond ((null s-field)
  62            (cons (cons field-type field-value) calist)
  63            )
  64           ((eq field-value t)
  65            calist)
  66           ((equal (cdr s-field) field-value)
  67            calist))))
  68
  69 (define-calist-field-match-method t #'calist-default-field-match-method)
  70
  71 (defsubst calist-field-match-method (field-type)
  72   (symbol-function
  73    (or (intern-soft
  74         (symbol-name field-type) calist-field-match-method-obarray)
  75        (intern-soft "t" calist-field-match-method-obarray))))
  76
  77 (defsubst calist-field-match (calist field-type field-value)
  78   (funcall (calist-field-match-method field-type)
  79            calist field-type field-value))
  80
  81 (defun ctree-match-calist (rule-tree alist)
  82   "Return matched condition-alist if ALIST matches RULE-TREE."
  83   (if (null rule-tree)
  84       alist
  85     (let ((type (car rule-tree))
  86           (choices (cdr rule-tree))
  87           default)
  88       (catch 'tag
  89         (while choices
  90           (let* ((choice (car choices))
  91                  (choice-value (car choice)))
  92             (if (eq choice-value t)
  93                 (setq default choice)
  94               (let ((ret-alist (calist-field-match alist type (car choice))))
  95                 (if ret-alist
  96                     (throw 'tag
  97                            (if (cdr choice)
  98                                (ctree-match-calist (cdr choice) ret-alist)
  99                              ret-alist))
 100                   ))))
 101           (setq choices (cdr choices)))
 102         (if default
 103             (let ((ret-alist (calist-field-match alist type t)))
 104               (if ret-alist
 105                   (if (cdr default)
 106                       (ctree-match-calist (cdr default) ret-alist)
 107                     ret-alist))))
 108         ))))
 109
 110 (defun ctree-match-calist-partially (rule-tree alist)
 111   "Return matched condition-alist if ALIST matches RULE-TREE."
 112   (if (null rule-tree)
 113       alist
 114     (let ((type (car rule-tree))
 115           (choices (cdr rule-tree))
 116           default)
 117       (catch 'tag
 118         (while choices
 119           (let* ((choice (car choices))
 120                  (choice-value (car choice)))
 121             (if (eq choice-value t)
 122                 (setq default choice)
 123               (let ((ret-alist (calist-field-match alist type (car choice))))
 124                 (if ret-alist
 125                     (throw 'tag
 126                            (if (cdr choice)
 127                                (ctree-match-calist-partially
 128                                 (cdr choice) ret-alist)
 129                              ret-alist))
 130                   ))))
 131           (setq choices (cdr choices)))
 132         (if default
 133             (let ((ret-alist (calist-field-match alist type t)))
 134               (if ret-alist
 135                   (if (cdr default)
 136                       (ctree-match-calist-partially (cdr default) ret-alist)
 137                     ret-alist)))
 138           (calist-field-match alist type t))
 139         ))))
 140
 141 (defun ctree-find-calist (rule-tree alist &optional all)
 142   "Return list of condition-alist which matches ALIST in RULE-TREE.
 143 If optional argument ALL is specified, default rules are not ignored
 144 even if other rules are matched for ALIST."
 145   (if (null rule-tree)
 146       (list alist)
 147     (let ((type (car rule-tree))
 148           (choices (cdr rule-tree))
 149           default dest)
 150       (while choices
 151         (let* ((choice (car choices))
 152                (choice-value (car choice)))
 153           (if (eq choice-value t)
 154               (setq default choice)
 155             (let ((ret-alist (calist-field-match alist type (car choice))))
 156               (if ret-alist
 157                   (if (cdr choice)
 158                       (let ((ret (ctree-find-calist
 159                                   (cdr choice) ret-alist all)))
 160                         (while ret
 161                           (let ((elt (car ret)))
 162                             (or (member elt dest)
 163                                 (setq dest (cons elt dest))
 164                                 ))
 165                           (setq ret (cdr ret))
 166                           ))
 167                     (or (member ret-alist dest)
 168                         (setq dest (cons ret-alist dest)))
 169                     )))))
 170         (setq choices (cdr choices)))
 171       (or (and (not all) dest)
 172           (if default
 173               (let ((ret-alist (calist-field-match alist type t)))
 174                 (if ret-alist
 175                     (if (cdr default)
 176                         (let ((ret (ctree-find-calist
 177                                     (cdr default) ret-alist all)))
 178                           (while ret
 179                             (let ((elt (car ret)))
 180                               (or (member elt dest)
 181                                   (setq dest (cons elt dest))
 182                                   ))
 183                             (setq ret (cdr ret))
 184                             ))
 185                       (or (member ret-alist dest)
 186                           (setq dest (cons ret-alist dest)))
 187                       ))))
 188           )
 189       dest)))
 190
 191 (defun calist-to-ctree (calist)
 192   "Convert condition-alist CALIST to condition-tree."
 193   (if calist
 194       (let* ((cell (car calist)))
 195         (cons (car cell)
 196               (list (cons (cdr cell)
 197                           (calist-to-ctree (cdr calist))
 198                           ))))))
 199
 200 (defun ctree-add-calist-strictly (ctree calist)
 201   "Add condition CALIST to condition-tree CTREE without default clause."
 202   (cond ((null calist) ctree)
 203         ((null ctree)
 204          (calist-to-ctree calist)
 205          )
 206         (t
 207          (let* ((type (car ctree))
 208                 (values (cdr ctree))
 209                 (ret (assoc type calist)))
 210            (if ret
 211                (catch 'tag
 212                  (while values
 213                    (let ((cell (car values)))
 214                      (if (equal (car cell)(cdr ret))
 215                          (throw 'tag
 216                                 (setcdr cell
 217                                         (ctree-add-calist-strictly
 218                                          (cdr cell)
 219                                          (delete ret (copy-alist calist)))
 220                                         ))))
 221                    (setq values (cdr values)))
 222                  (setcdr ctree (cons (cons (cdr ret)
 223                                            (calist-to-ctree
 224                                             (delete ret (copy-alist calist))))
 225                                      (cdr ctree)))
 226                  )
 227              (catch 'tag
 228                (while values
 229                  (let ((cell (car values)))
 230                    (setcdr cell
 231                            (ctree-add-calist-strictly (cdr cell) calist))
 232                    )
 233                  (setq values (cdr values))))
 234              )
 235            ctree))))
 236
 237 (defun ctree-add-calist-with-default (ctree calist)
 238   "Add condition CALIST to condition-tree CTREE with default clause."
 239   (cond ((null calist) ctree)
 240         ((null ctree)
 241          (let* ((cell (car calist))
 242                 (type (car cell))
 243                 (value (cdr cell)))
 244            (cons type
 245                  (list (list t)
 246                        (cons value (calist-to-ctree (cdr calist)))))
 247            ))
 248         (t
 249          (let* ((type (car ctree))
 250                 (values (cdr ctree))
 251                 (ret (assoc type calist)))
 252            (if ret
 253                (catch 'tag
 254                  (while values
 255                    (let ((cell (car values)))
 256                      (if (equal (car cell)(cdr ret))
 257                          (throw 'tag
 258                                 (setcdr cell
 259                                         (ctree-add-calist-with-default
 260                                          (cdr cell)
 261                                          (delete ret (copy-alist calist)))
 262                                         ))))
 263                    (setq values (cdr values)))
 264                  (if (assq t (cdr ctree))
 265                      (setcdr ctree
 266                              (cons (cons (cdr ret)
 267                                          (calist-to-ctree
 268                                           (delete ret (copy-alist calist))))
 269                                    (cdr ctree)))
 270                    (setcdr ctree
 271                            (list* (list t)
 272                                   (cons (cdr ret)
 273                                         (calist-to-ctree
 274                                          (delete ret (copy-alist calist))))
 275                                   (cdr ctree)))
 276                    ))
 277              (catch 'tag
 278                (while values
 279                  (let ((cell (car values)))
 280                    (setcdr cell
 281                            (ctree-add-calist-with-default (cdr cell) calist))
 282                    )
 283                  (setq values (cdr values)))
 284                (let ((cell (assq t (cdr ctree))))
 285                  (if cell
 286                      (setcdr cell
 287                              (ctree-add-calist-with-default (cdr cell)
 288                                                             calist))
 289                    (let ((elt (cons t (calist-to-ctree calist))))
 290                      (or (member elt (cdr ctree))
 291                          (setcdr ctree (cons elt (cdr ctree)))
 292                          ))
 293                    )))
 294              )
 295            ctree))))
 296
 297 (defun ctree-set-calist-strictly (ctree-var calist)
 298   "Set condition CALIST in CTREE-VAR without default clause."
 299   (set ctree-var
 300        (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
 301
 302 (defun ctree-set-calist-with-default (ctree-var calist)
 303   "Set condition CALIST to CTREE-VAR with default clause."
 304   (set ctree-var
 305        (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
 306
 307
 308 ;;; @ end
 309 ;;;
 310
 311 (provide 'calist)
 312
 313 ;;; calist.el ends here