;;; calist.el --- Condition functions
-;; Copyright (C) 1998 MORIOKA Tomohiko.
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; Keywords: condition, alist, tree
;; This file is part of APEL (A Portable Emacs Library).
(eval-when-compile (require 'cl))
-(defvar calist-field-match-method-obarray [nil])
+(require 'alist)
+
+(defvar calist-package-alist nil)
+(defvar calist-field-match-method-obarray nil)
+
+(defun find-calist-package (name)
+ "Return a calist-package by NAME."
+ (cdr (assq name calist-package-alist)))
(defun define-calist-field-match-method (field-type function)
"Set field-match-method for FIELD-TYPE to FUNCTION."
(fset (intern (symbol-name field-type) calist-field-match-method-obarray)
function))
+(defun use-calist-package (name)
+ "Make the symbols of package NAME accessible in the current package."
+ (mapatoms (lambda (sym)
+ (if (intern-soft (symbol-name sym)
+ calist-field-match-method-obarray)
+ (signal 'conflict-of-calist-symbol
+ (list (format "Conflict of symbol %s")))
+ (if (fboundp sym)
+ (define-calist-field-match-method
+ sym (symbol-function sym))
+ )))
+ (find-calist-package name)))
+
+(defun make-calist-package (name &optional use)
+ "Create a new calist-package."
+ (let ((calist-field-match-method-obarray (make-vector 7 0)))
+ (set-alist 'calist-package-alist name
+ calist-field-match-method-obarray)
+ (use-calist-package (or use 'standard))
+ calist-field-match-method-obarray))
+
+(defun in-calist-package (name)
+ "Set the current calist-package to a new or existing calist-package."
+ (setq calist-field-match-method-obarray
+ (or (find-calist-package name)
+ (make-calist-package name))))
+
+(in-calist-package 'standard)
+
(defun calist-default-field-match-method (calist field-type field-value)
(let ((s-field (assoc field-type calist)))
(cond ((null s-field)
((equal (cdr s-field) field-value)
calist))))
+(define-calist-field-match-method t #'calist-default-field-match-method)
+
(defsubst calist-field-match-method (field-type)
- (condition-case nil
- (symbol-function
- (intern-soft
- (symbol-name field-type) calist-field-match-method-obarray))
- (error (symbol-function 'calist-default-field-match-method))
- ))
+ (symbol-function
+ (or (intern-soft (if (symbolp field-type)
+ (symbol-name field-type)
+ field-type)
+ calist-field-match-method-obarray)
+ (intern-soft "t" calist-field-match-method-obarray))))
(defsubst calist-field-match (calist field-type field-value)
(funcall (calist-field-match-method field-type)
(let ((ret-alist (calist-field-match alist type (car choice))))
(if ret-alist
(if (cdr choice)
- (setq dest
- (append (ctree-find-calist
- (cdr choice) ret-alist all)
- dest))
+ (let ((ret (ctree-find-calist
+ (cdr choice) ret-alist all)))
+ (while ret
+ (let ((elt (car ret)))
+ (or (member elt dest)
+ (setq dest (cons elt dest))
+ ))
+ (setq ret (cdr ret))
+ ))
(or (member ret-alist dest)
(setq dest (cons ret-alist dest)))
)))))
(let ((ret-alist (calist-field-match alist type t)))
(if ret-alist
(if (cdr default)
- (setq dest
- (append (ctree-find-calist
- (cdr default) ret-alist all)
- dest))
+ (let ((ret (ctree-find-calist
+ (cdr default) ret-alist all)))
+ (while ret
+ (let ((elt (car ret)))
+ (or (member elt dest)
+ (setq dest (cons elt dest))
+ ))
+ (setq ret (cdr ret))
+ ))
(or (member ret-alist dest)
(setq dest (cons ret-alist dest)))
))))
(type (car cell))
(value (cdr cell)))
(cons type
- (list '(t)
+ (list (list t)
(cons value (calist-to-ctree (cdr calist)))))
))
(t
(delete ret (copy-alist calist)))
))))
(setq values (cdr values)))
- (setcdr ctree (list* '(t)
- (cons (cdr ret)
- (calist-to-ctree
- (delete ret (copy-alist calist))))
- (cdr ctree)))
- )
+ (if (assq t (cdr ctree))
+ (setcdr ctree
+ (cons (cons (cdr ret)
+ (calist-to-ctree
+ (delete ret (copy-alist calist))))
+ (cdr ctree)))
+ (setcdr ctree
+ (list* (list t)
+ (cons (cdr ret)
+ (calist-to-ctree
+ (delete ret (copy-alist calist))))
+ (cdr ctree)))
+ ))
(catch 'tag
(while values
(let ((cell (car values)))
(ctree-add-calist-with-default (cdr cell) calist))
)
(setq values (cdr values)))
- (let ((elt (cons t (calist-to-ctree calist))))
- (or (member elt (cdr ctree))
- (setcdr ctree (cons elt (cdr ctree)))
- )))
+ (let ((cell (assq t (cdr ctree))))
+ (if cell
+ (setcdr cell
+ (ctree-add-calist-with-default (cdr cell)
+ calist))
+ (let ((elt (cons t (calist-to-ctree calist))))
+ (or (member elt (cdr ctree))
+ (setcdr ctree (cons elt (cdr ctree)))
+ ))
+ )))
)
ctree))))