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 (defun ctree-match-calist (rule-tree alist)
  30   "Return matched condition-alist if ALIST matches RULE-TREE."
  31   (if (null rule-tree)
  32       alist
  33     (let* ((type (car rule-tree))
  34            (values (cdr rule-tree))
  35            (k-value (assoc type alist)))
  36       (catch 'tag
  37         (while values
  38           (let ((cell (car values)))
  39             (cond ((null k-value)
  40                    (throw 'tag
  41                           (if (cdr cell)
  42                               (ctree-match-calist
  43                                (cdr cell)
  44                                (cons (cons type (car cell)) alist))
  45                             (cons (cons type (car cell)) alist)
  46                             )))
  47                   ((eq (car cell) t)
  48                    (throw 'tag
  49                           (if (cdr k-value)
  50                               (ctree-match-calist (cdr cell) alist)
  51                             alist)
  52                           ))
  53                   ((equal (car cell) (cdr k-value))
  54                    (throw 'tag
  55                           (if (cdr cell)
  56                               (ctree-match-calist (cdr cell) alist)
  57                             alist)
  58                           ))
  59                   ))
  60           (setq values (cdr values))))
  61       )))
  62
  63 (defun calist-to-ctree (calist)
  64   "Convert condition-alist CALIST to condition-tree."
  65   (if calist
  66       (let* ((cell (car calist)))
  67         (cons (car cell)
  68               (list (cons (cdr cell)
  69                           (calist-to-ctree (cdr calist))
  70                           ))))))
  71
  72 (defun ctree-add-calist-strictly (ctree calist)
  73   "Add condition CALIST to condition-tree CTREE without default clause."
  74   (cond ((null calist) ctree)
  75         ((null ctree)
  76          (calist-to-ctree calist)
  77          )
  78         (t
  79          (let* ((type (car ctree))
  80                 (values (cdr ctree))
  81                 (ret (assoc type calist)))
  82            (if ret
  83                (catch 'tag
  84                  (while values
  85                    (let ((cell (car values)))
  86                      (if (equal (car cell)(cdr ret))
  87                          (throw 'tag
  88                                 (setcdr cell
  89                                         (ctree-add-calist-strictly
  90                                          (cdr cell)
  91                                          (delete ret (copy-alist calist)))
  92                                         ))))
  93                    (setq values (cdr values)))
  94                  (setcdr ctree (cons (cons (cdr ret)
  95                                            (calist-to-ctree
  96                                             (delete ret (copy-alist calist))))
  97                                      (cdr ctree)))
  98                  )
  99              (catch 'tag
 100                (while values
 101                  (let ((cell (car values)))
 102                    (setcdr cell
 103                            (ctree-add-calist-strictly (cdr cell) calist))
 104                    )
 105                  (setq values (cdr values))))
 106              )
 107            ctree))))
 108
 109 (defun ctree-add-calist-with-default (ctree calist)
 110   "Add condition CALIST to condition-tree CTREE with default clause."
 111   (cond ((null calist) ctree)
 112         ((null ctree)
 113          (let* ((cell (car calist))
 114                 (type (car cell))
 115                 (value (cdr cell)))
 116            (cons type
 117                  (list '(t)
 118                        (cons value (calist-to-ctree (cdr calist)))))
 119            ))
 120         (t
 121          (let* ((type (car ctree))
 122                 (values (cdr ctree))
 123                 (ret (assoc type calist)))
 124            (if ret
 125                (catch 'tag
 126                  (while values
 127                    (let ((cell (car values)))
 128                      (if (equal (car cell)(cdr ret))
 129                          (throw 'tag
 130                                 (setcdr cell
 131                                         (ctree-add-calist-with-default
 132                                          (cdr cell)
 133                                          (delete ret (copy-alist calist)))
 134                                         ))))
 135                    (setq values (cdr values)))
 136                  (setcdr ctree (list* '(t)
 137                                       (cons (cdr ret)
 138                                             (calist-to-ctree
 139                                              (delete ret (copy-alist calist))))
 140                                       (cdr ctree)))
 141                  )
 142              (catch 'tag
 143                (while values
 144                  (let ((cell (car values)))
 145                    (setcdr cell
 146                            (ctree-add-calist-with-default (cdr cell) calist))
 147                    )
 148                  (setq values (cdr values)))
 149                (let ((elt (cons t (calist-to-ctree calist))))
 150                  (or (member elt (cdr ctree))
 151                      (setcdr ctree (cons elt (cdr ctree)))
 152                      )))
 153              )
 154            ctree))))
 155
 156 (defun ctree-set-calist-strictly (ctree-var calist)
 157   "Set condition CALIST in CTREE-VAR without default clause."
 158   (set ctree-var
 159        (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
 160
 161 (defun ctree-set-calist-with-default (ctree-var calist)
 162   "Set condition CALIST to CTREE-VAR with default clause."
 163   (set ctree-var
 164        (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
 165
 166
 167 ;;; @ end
 168 ;;;
 169
 170 (provide 'calist)
 171
 172 ;;; calist.el ends here