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 find-calist-package (name)
  37   "Return a calist-package by NAME."
  38   (cdr (assq name calist-package-alist)))
  39
  40 (defun define-calist-field-match-method (field-type function)
  41   "Set field-match-method for FIELD-TYPE to FUNCTION."
  42   (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
  43         function))
  44
  45 (defun use-calist-package (name)
  46   "Make the symbols of package NAME accessible in the current package."
  47   (mapatoms (lambda (sym)
  48               (if (intern-soft (symbol-name sym)
  49                                calist-field-match-method-obarray)
  50                   (signal 'conflict-of-calist-symbol
  51                           (list (format "Conflict of symbol %s")))
  52                 (if (fboundp sym)
  53                     (define-calist-field-match-method
  54                       sym (symbol-function sym))
  55                   )))
  56             (find-calist-package name)))
  57
  58 (defun make-calist-package (name &optional use)
  59   "Create a new calist-package."
  60   (let ((calist-field-match-method-obarray (make-vector 7 0)))
  61     (set-alist 'calist-package-alist name
  62                calist-field-match-method-obarray)
  63     (use-calist-package (or use 'standard))
  64     calist-field-match-method-obarray))
  65
  66 (defun in-calist-package (name)
  67   "Set the current calist-package to a new or existing calist-package."
  68   (setq calist-field-match-method-obarray
  69         (or (find-calist-package name)
  70             (make-calist-package name))))
  71
  72 (in-calist-package 'standard)
  73
  74 (defun calist-default-field-match-method (calist field-type field-value)
  75   (let ((s-field (assoc field-type calist)))
  76     (cond ((null s-field)
  77            (cons (cons field-type field-value) calist)
  78            )
  79           ((eq field-value t)
  80            calist)
  81           ((equal (cdr s-field) field-value)
  82            calist))))
  83
  84 (define-calist-field-match-method t #'calist-default-field-match-method)
  85
  86 (defsubst calist-field-match-method (field-type)
  87   (symbol-function
  88    (or (intern-soft
  89         (symbol-name field-type) calist-field-match-method-obarray)
  90        (intern-soft "t" calist-field-match-method-obarray))))
  91
  92 (defsubst calist-field-match (calist field-type field-value)
  93   (funcall (calist-field-match-method field-type)
  94            calist field-type field-value))
  95
  96 (defun ctree-match-calist (rule-tree alist)
  97   "Return matched condition-alist if ALIST matches RULE-TREE."
  98   (if (null rule-tree)
  99       alist
 100     (let ((type (car rule-tree))
 101           (choices (cdr rule-tree))
 102           default)
 103       (catch 'tag
 104         (while choices
 105           (let* ((choice (car choices))
 106                  (choice-value (car choice)))
 107             (if (eq choice-value t)
 108                 (setq default choice)
 109               (let ((ret-alist (calist-field-match alist type (car choice))))
 110                 (if ret-alist
 111                     (throw 'tag
 112                            (if (cdr choice)
 113                                (ctree-match-calist (cdr choice) ret-alist)
 114                              ret-alist))
 115                   ))))
 116           (setq choices (cdr choices)))
 117         (if default
 118             (let ((ret-alist (calist-field-match alist type t)))
 119               (if ret-alist
 120                   (if (cdr default)
 121                       (ctree-match-calist (cdr default) ret-alist)
 122                     ret-alist))))
 123         ))))
 124
 125 (defun ctree-match-calist-partially (rule-tree alist)
 126   "Return matched condition-alist if ALIST matches RULE-TREE."
 127   (if (null rule-tree)
 128       alist
 129     (let ((type (car rule-tree))
 130           (choices (cdr rule-tree))
 131           default)
 132       (catch 'tag
 133         (while choices
 134           (let* ((choice (car choices))
 135                  (choice-value (car choice)))
 136             (if (eq choice-value t)
 137                 (setq default choice)
 138               (let ((ret-alist (calist-field-match alist type (car choice))))
 139                 (if ret-alist
 140                     (throw 'tag
 141                            (if (cdr choice)
 142                                (ctree-match-calist-partially
 143                                 (cdr choice) ret-alist)
 144                              ret-alist))
 145                   ))))
 146           (setq choices (cdr choices)))
 147         (if default
 148             (let ((ret-alist (calist-field-match alist type t)))
 149               (if ret-alist
 150                   (if (cdr default)
 151                       (ctree-match-calist-partially (cdr default) ret-alist)
 152                     ret-alist)))
 153           (calist-field-match alist type t))
 154         ))))
 155
 156 (defun ctree-find-calist (rule-tree alist &optional all)
 157   "Return list of condition-alist which matches ALIST in RULE-TREE.
 158 If optional argument ALL is specified, default rules are not ignored
 159 even if other rules are matched for ALIST."
 160   (if (null rule-tree)
 161       (list alist)
 162     (let ((type (car rule-tree))
 163           (choices (cdr rule-tree))
 164           default dest)
 165       (while choices
 166         (let* ((choice (car choices))
 167                (choice-value (car choice)))
 168           (if (eq choice-value t)
 169               (setq default choice)
 170             (let ((ret-alist (calist-field-match alist type (car choice))))
 171               (if ret-alist
 172                   (if (cdr choice)
 173                       (let ((ret (ctree-find-calist
 174                                   (cdr choice) ret-alist all)))
 175                         (while ret
 176                           (let ((elt (car ret)))
 177                             (or (member elt dest)
 178                                 (setq dest (cons elt dest))
 179                                 ))
 180                           (setq ret (cdr ret))
 181                           ))
 182                     (or (member ret-alist dest)
 183                         (setq dest (cons ret-alist dest)))
 184                     )))))
 185         (setq choices (cdr choices)))
 186       (or (and (not all) dest)
 187           (if default
 188               (let ((ret-alist (calist-field-match alist type t)))
 189                 (if ret-alist
 190                     (if (cdr default)
 191                         (let ((ret (ctree-find-calist
 192                                     (cdr default) ret-alist all)))
 193                           (while ret
 194                             (let ((elt (car ret)))
 195                               (or (member elt dest)
 196                                   (setq dest (cons elt dest))
 197                                   ))
 198                             (setq ret (cdr ret))
 199                             ))
 200                       (or (member ret-alist dest)
 201                           (setq dest (cons ret-alist dest)))
 202                       ))))
 203           )
 204       dest)))
 205
 206 (defun calist-to-ctree (calist)
 207   "Convert condition-alist CALIST to condition-tree."
 208   (if calist
 209       (let* ((cell (car calist)))
 210         (cons (car cell)
 211               (list (cons (cdr cell)
 212                           (calist-to-ctree (cdr calist))
 213                           ))))))
 214
 215 (defun ctree-add-calist-strictly (ctree calist)
 216   "Add condition CALIST to condition-tree CTREE without default clause."
 217   (cond ((null calist) ctree)
 218         ((null ctree)
 219          (calist-to-ctree calist)
 220          )
 221         (t
 222          (let* ((type (car ctree))
 223                 (values (cdr ctree))
 224                 (ret (assoc type calist)))
 225            (if ret
 226                (catch 'tag
 227                  (while values
 228                    (let ((cell (car values)))
 229                      (if (equal (car cell)(cdr ret))
 230                          (throw 'tag
 231                                 (setcdr cell
 232                                         (ctree-add-calist-strictly
 233                                          (cdr cell)
 234                                          (delete ret (copy-alist calist)))
 235                                         ))))
 236                    (setq values (cdr values)))
 237                  (setcdr ctree (cons (cons (cdr ret)
 238                                            (calist-to-ctree
 239                                             (delete ret (copy-alist calist))))
 240                                      (cdr ctree)))
 241                  )
 242              (catch 'tag
 243                (while values
 244                  (let ((cell (car values)))
 245                    (setcdr cell
 246                            (ctree-add-calist-strictly (cdr cell) calist))
 247                    )
 248                  (setq values (cdr values))))
 249              )
 250            ctree))))
 251
 252 (defun ctree-add-calist-with-default (ctree calist)
 253   "Add condition CALIST to condition-tree CTREE with default clause."
 254   (cond ((null calist) ctree)
 255         ((null ctree)
 256          (let* ((cell (car calist))
 257                 (type (car cell))
 258                 (value (cdr cell)))
 259            (cons type
 260                  (list (list t)
 261                        (cons value (calist-to-ctree (cdr calist)))))
 262            ))
 263         (t
 264          (let* ((type (car ctree))
 265                 (values (cdr ctree))
 266                 (ret (assoc type calist)))
 267            (if ret
 268                (catch 'tag
 269                  (while values
 270                    (let ((cell (car values)))
 271                      (if (equal (car cell)(cdr ret))
 272                          (throw 'tag
 273                                 (setcdr cell
 274                                         (ctree-add-calist-with-default
 275                                          (cdr cell)
 276                                          (delete ret (copy-alist calist)))
 277                                         ))))
 278                    (setq values (cdr values)))
 279                  (if (assq t (cdr ctree))
 280                      (setcdr ctree
 281                              (cons (cons (cdr ret)
 282                                          (calist-to-ctree
 283                                           (delete ret (copy-alist calist))))
 284                                    (cdr ctree)))
 285                    (setcdr ctree
 286                            (list* (list t)
 287                                   (cons (cdr ret)
 288                                         (calist-to-ctree
 289                                          (delete ret (copy-alist calist))))
 290                                   (cdr ctree)))
 291                    ))
 292              (catch 'tag
 293                (while values
 294                  (let ((cell (car values)))
 295                    (setcdr cell
 296                            (ctree-add-calist-with-default (cdr cell) calist))
 297                    )
 298                  (setq values (cdr values)))
 299                (let ((cell (assq t (cdr ctree))))
 300                  (if cell
 301                      (setcdr cell
 302                              (ctree-add-calist-with-default (cdr cell)
 303                                                             calist))
 304                    (let ((elt (cons t (calist-to-ctree calist))))
 305                      (or (member elt (cdr ctree))
 306                          (setcdr ctree (cons elt (cdr ctree)))
 307                          ))
 308                    )))
 309              )
 310            ctree))))
 311
 312 (defun ctree-set-calist-strictly (ctree-var calist)
 313   "Set condition CALIST in CTREE-VAR without default clause."
 314   (set ctree-var
 315        (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
 316
 317 (defun ctree-set-calist-with-default (ctree-var calist)
 318   "Set condition CALIST to CTREE-VAR with default clause."
 319   (set ctree-var
 320        (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
 321
 322
 323 ;;; @ end
 324 ;;;
 325
 326 (provide 'calist)
 327
 328 ;;; calist.el ends here