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., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, 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" sym)))
  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 (function calist-default-field-match-method))
  85
  86 (defsubst calist-field-match-method (field-type)
  87   (symbol-function
  88    (or (intern-soft (if (symbolp field-type)
  89                         (symbol-name field-type)
  90                       field-type)
  91                     calist-field-match-method-obarray)
  92        (intern-soft "t" calist-field-match-method-obarray))))
  93
  94 (defsubst calist-field-match (calist field-type field-value)
  95   (funcall (calist-field-match-method field-type)
  96            calist field-type field-value))
  97
  98 (defun ctree-match-calist (rule-tree alist)
  99   "Return matched condition-alist if ALIST matches RULE-TREE."
 100   (if (null rule-tree)
 101       alist
 102     (let ((type (car rule-tree))
 103           (choices (cdr rule-tree))
 104           default)
 105       (catch 'tag
 106         (while choices
 107           (let* ((choice (car choices))
 108                  (choice-value (car choice)))
 109             (if (eq choice-value t)
 110                 (setq default choice)
 111               (let ((ret-alist (calist-field-match alist type (car choice))))
 112                 (if ret-alist
 113                     (throw 'tag
 114                            (if (cdr choice)
 115                                (ctree-match-calist (cdr choice) ret-alist)
 116                              ret-alist))
 117                   ))))
 118           (setq choices (cdr choices)))
 119         (if default
 120             (let ((ret-alist (calist-field-match alist type t)))
 121               (if ret-alist
 122                   (if (cdr default)
 123                       (ctree-match-calist (cdr default) ret-alist)
 124                     ret-alist))))
 125         ))))
 126
 127 (defun ctree-match-calist-partially (rule-tree alist)
 128   "Return matched condition-alist if ALIST matches RULE-TREE."
 129   (if (null rule-tree)
 130       alist
 131     (let ((type (car rule-tree))
 132           (choices (cdr rule-tree))
 133           default)
 134       (catch 'tag
 135         (while choices
 136           (let* ((choice (car choices))
 137                  (choice-value (car choice)))
 138             (if (eq choice-value t)
 139                 (setq default choice)
 140               (let ((ret-alist (calist-field-match alist type (car choice))))
 141                 (if ret-alist
 142                     (throw 'tag
 143                            (if (cdr choice)
 144                                (ctree-match-calist-partially
 145                                 (cdr choice) ret-alist)
 146                              ret-alist))
 147                   ))))
 148           (setq choices (cdr choices)))
 149         (if default
 150             (let ((ret-alist (calist-field-match alist type t)))
 151               (if ret-alist
 152                   (if (cdr default)
 153                       (ctree-match-calist-partially (cdr default) ret-alist)
 154                     ret-alist)))
 155           (calist-field-match alist type t))
 156         ))))
 157
 158 (defun ctree-find-calist (rule-tree alist &optional all)
 159   "Return list of condition-alist which matches ALIST in RULE-TREE.
 160 If optional argument ALL is specified, default rules are not ignored
 161 even if other rules are matched for ALIST."
 162   (if (null rule-tree)
 163       (list alist)
 164     (let ((type (car rule-tree))
 165           (choices (cdr rule-tree))
 166           default dest)
 167       (while choices
 168         (let* ((choice (car choices))
 169                (choice-value (car choice)))
 170           (if (eq choice-value t)
 171               (setq default choice)
 172             (let ((ret-alist (calist-field-match alist type (car choice))))
 173               (if ret-alist
 174                   (if (cdr choice)
 175                       (let ((ret (ctree-find-calist
 176                                   (cdr choice) ret-alist all)))
 177                         (while ret
 178                           (let ((elt (car ret)))
 179                             (or (member elt dest)
 180                                 (setq dest (cons elt dest))
 181                                 ))
 182                           (setq ret (cdr ret))
 183                           ))
 184                     (or (member ret-alist dest)
 185                         (setq dest (cons ret-alist dest)))
 186                     )))))
 187         (setq choices (cdr choices)))
 188       (or (and (not all) dest)
 189           (if default
 190               (let ((ret-alist (calist-field-match alist type t)))
 191                 (if ret-alist
 192                     (if (cdr default)
 193                         (let ((ret (ctree-find-calist
 194                                     (cdr default) ret-alist all)))
 195                           (while ret
 196                             (let ((elt (car ret)))
 197                               (or (member elt dest)
 198                                   (setq dest (cons elt dest))
 199                                   ))
 200                             (setq ret (cdr ret))
 201                             ))
 202                       (or (member ret-alist dest)
 203                           (setq dest (cons ret-alist dest)))
 204                       ))))
 205           )
 206       dest)))
 207
 208 (defun calist-to-ctree (calist)
 209   "Convert condition-alist CALIST to condition-tree."
 210   (if calist
 211       (let* ((cell (car calist)))
 212         (cons (car cell)
 213               (list (cons (cdr cell)
 214                           (calist-to-ctree (cdr calist))
 215                           ))))))
 216
 217 (defun ctree-add-calist-strictly (ctree calist)
 218   "Add condition CALIST to condition-tree CTREE without default clause."
 219   (cond ((null calist) ctree)
 220         ((null ctree)
 221          (calist-to-ctree calist)
 222          )
 223         (t
 224          (let* ((type (car ctree))
 225                 (values (cdr ctree))
 226                 (ret (assoc type calist)))
 227            (if ret
 228                (catch 'tag
 229                  (while values
 230                    (let ((cell (car values)))
 231                      (if (equal (car cell)(cdr ret))
 232                          (throw 'tag
 233                                 (setcdr cell
 234                                         (ctree-add-calist-strictly
 235                                          (cdr cell)
 236                                          (delete ret (copy-alist calist)))
 237                                         ))))
 238                    (setq values (cdr values)))
 239                  (setcdr ctree (cons (cons (cdr ret)
 240                                            (calist-to-ctree
 241                                             (delete ret (copy-alist calist))))
 242                                      (cdr ctree)))
 243                  )
 244              (catch 'tag
 245                (while values
 246                  (let ((cell (car values)))
 247                    (setcdr cell
 248                            (ctree-add-calist-strictly (cdr cell) calist))
 249                    )
 250                  (setq values (cdr values))))
 251              )
 252            ctree))))
 253
 254 (defun ctree-add-calist-with-default (ctree calist)
 255   "Add condition CALIST to condition-tree CTREE with default clause."
 256   (cond ((null calist) ctree)
 257         ((null ctree)
 258          (let* ((cell (car calist))
 259                 (type (car cell))
 260                 (value (cdr cell)))
 261            (cons type
 262                  (list (list t)
 263                        (cons value (calist-to-ctree (cdr calist)))))
 264            ))
 265         (t
 266          (let* ((type (car ctree))
 267                 (values (cdr ctree))
 268                 (ret (assoc type calist)))
 269            (if ret
 270                (catch 'tag
 271                  (while values
 272                    (let ((cell (car values)))
 273                      (if (equal (car cell)(cdr ret))
 274                          (throw 'tag
 275                                 (setcdr cell
 276                                         (ctree-add-calist-with-default
 277                                          (cdr cell)
 278                                          (delete ret (copy-alist calist)))
 279                                         ))))
 280                    (setq values (cdr values)))
 281                  (if (assq t (cdr ctree))
 282                      (setcdr ctree
 283                              (cons (cons (cdr ret)
 284                                          (calist-to-ctree
 285                                           (delete ret (copy-alist calist))))
 286                                    (cdr ctree)))
 287                    (setcdr ctree
 288                            (list* (list t)
 289                                   (cons (cdr ret)
 290                                         (calist-to-ctree
 291                                          (delete ret (copy-alist calist))))
 292                                   (cdr ctree)))
 293                    ))
 294              (catch 'tag
 295                (while values
 296                  (let ((cell (car values)))
 297                    (setcdr cell
 298                            (ctree-add-calist-with-default (cdr cell) calist))
 299                    )
 300                  (setq values (cdr values)))
 301                (let ((cell (assq t (cdr ctree))))
 302                  (if cell
 303                      (setcdr cell
 304                              (ctree-add-calist-with-default (cdr cell)
 305                                                             calist))
 306                    (let ((elt (cons t (calist-to-ctree calist))))
 307                      (or (member elt (cdr ctree))
 308                          (setcdr ctree (cons elt (cdr ctree)))
 309                          ))
 310                    )))
 311              )
 312            ctree))))
 313
 314 (defun ctree-set-calist-strictly (ctree-var calist)
 315   "Set condition CALIST in CTREE-VAR without default clause."
 316   (set ctree-var
 317        (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
 318
 319 (defun ctree-set-calist-with-default (ctree-var calist)
 320   "Set condition CALIST to CTREE-VAR with default clause."
 321   (set ctree-var
 322        (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
 323
 324
 325 ;;; @ end
 326 ;;;
 327
 328 (require 'product)
 329 (product-provide (provide 'calist) (require 'apel-ver))
 330
 331 ;;; calist.el ends here