cgit.sxemacs.org Git - packages/blob - xemacs-packages/liece/lisp/liece-inlines.el

   1 ;;; liece-inlines.el --- Inline macros for various use.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Revised: 1998-11-25
   7 ;; Keywords: IRC, liece
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (require 'liece-globals)
  33 (require 'liece-compat)
  34 (require 'liece-setup)
  35 (require 'liece-vars)
  36
  37 (eval-when-compile (require 'liece-clfns))
  38
  39 ;;; @ string functions
  40 ;;;
  41 (defmacro string-times (str n)
  42   `(apply #'concat (make-list ,n ,str)))
  43
  44 (defmacro string-join (strlst &optional del)
  45   `(mapconcat #'identity ,strlst ,del))
  46
  47 (defmacro string-equal-ignore-case (s1 s2)
  48   `(string-equal (upcase ,s1) (upcase ,s2)))
  49
  50 (defsubst string-list-member-ignore-case (thing list)
  51   "Returns t if thing is member of list, not funcallable"
  52   (member-if
  53    (lambda (item)
  54      (and (stringp item) (string-equal-ignore-case thing item)))
  55    list))
  56
  57 (defsubst string-list-remove-ignore-case (thing list)
  58   (let ((element (string-list-member-ignore-case thing list)))
  59     (if element
  60         (remq (car element) list)
  61       list)))
  62
  63 (defsubst string-list-delete-ignore-case (thing list)
  64   (let ((element (string-list-member-ignore-case thing list)))
  65     (if element
  66         (delq (car element) list)
  67       list)))
  68
  69 (defsubst string-list-remove (thing list)
  70   (let ((element (member thing list)))
  71     (if element
  72         (remq (car element) list)
  73       list)))
  74
  75 (defsubst string-list-delete (thing list)
  76   (let ((element (member thing list)))
  77     (if element
  78         (delq (car element) list)
  79       list)))
  80
  81 (defsubst string-list-modify-ignore-case (modifiers list)
  82   (dolist (modifier modifiers)
  83     (let ((p list))
  84       (while p
  85         (if (string-equal-ignore-case (car modifier) (car p))
  86             (setcar p (cdr modifier)))
  87         (setq p (cdr p)))))
  88   list)
  89
  90 (static-if (fboundp 'assoc-ignore-case)
  91     (defalias 'string-assoc-ignore-case 'assoc-ignore-case)
  92   (defsubst string-assoc-ignore-case (key list)
  93     (assoc-if
  94      (lambda (item) (string-equal-ignore-case item key))
  95      list)))
  96
  97 (defsubst regexp-assoc-ignore-case (key list)
  98   "Assoc with REGEXP-KEY from LIST."
  99   (save-match-data
 100     (assoc-if
 101      (lambda (item)
 102        (string-match (concat "^" (upcase key)) "$") (upcase item))
 103      list)))
 104
 105 (defsubst regexp-rassoc-ignore-case (key list)
 106   "Assoc with KEY from LIST, in which keys are regexps."
 107   (rassoc-if
 108    (lambda (item)
 109      (string-match (concat "^" (upcase key) "$") (upcase item)))
 110    list))
 111
 112 (defmacro list-to-alist (list)
 113   `(mapcar #'list ,list))
 114
 115 (put 'filter-elements 'lisp-indent-function 2)
 116
 117 (defmacro filter-elements (element list condition)
 118   `(let (result tail ,element)
 119      (setq tail ,list)
 120      (while tail
 121        (setq ,element (car tail))
 122        (if ,condition
 123            (setq result (cons ,element result)))
 124        (setq tail (cdr tail)))
 125      (nreverse result)))
 126
 127 \f
 128 ;;; @ helper functions
 129 ;;;
 130 (defmacro liece-functionp (form)
 131   `(or (and (symbolp ,form) (fboundp ,form))
 132        (and (listp ,form) (eq (car ,form) 'lambda))
 133        (byte-code-function-p ,form)))
 134
 135 (defun liece-eval-form (form)
 136   (cond
 137    ((and (listp form) (liece-functionp (car form)))
 138     (eval form))
 139    ((and (symbolp form) (boundp form))
 140     (symbol-value form))
 141    (t form)))
 142
 143 (defun liece-or (&rest elems)
 144   "Return non-nil if any of the elements are non-nil."
 145   (catch 'found
 146     (while elems
 147       (when (pop elems)
 148         (throw 'found t)))))
 149
 150 (defun liece-and (&rest elems)
 151   "Return non-nil if all of the elements are non-nil."
 152   (catch 'found
 153     (while elems
 154       (unless (pop elems)
 155         (throw 'found nil)))
 156     t))
 157
 158 (defun liece-locate-path (subdir &optional filename)
 159   (let ((dir (liece-locate-data-directory
 160               (downcase (product-name (product-find 'liece-version))))))
 161     (when (and dir (file-directory-p dir))
 162       (if filename
 163           (expand-file-name filename (concat dir subdir))
 164         (concat dir subdir)))))
 165
 166 (defun liece-locate-icon-file (filename)
 167   (or liece-icon-directory
 168       (setq liece-icon-directory (liece-locate-path "icons")))
 169   (expand-file-name filename liece-icon-directory))
 170
 171 (defmacro liece-next-line (arg)
 172   `(let ((i 0))
 173      (while (< i ,arg)
 174        (if (eobp) (newline)(next-line 1))
 175        (setq i (1+ i)))))
 176
 177 ;; Borrowed from `edebug.el'.
 178 (defvar liece-gensym-index 0
 179   "Integer used by `liece-gensym' to produce new names.")
 180
 181 (defun liece-gensym (&optional prefix)
 182   "Generate a fresh uninterned symbol.
 183 There is an  optional argument, PREFIX.  PREFIX is the
 184 string that begins the new name. Most people take just the default,
 185 except when debugging needs suggest otherwise."
 186   (if (null prefix)
 187       (setq prefix "G"))
 188   (let ((newsymbol nil)
 189         (newname   ""))
 190     (while (not newsymbol)
 191       (setq newname (concat prefix (int-to-string liece-gensym-index))
 192             liece-gensym-index (1+ liece-gensym-index))
 193       (if (not (intern-soft newname))
 194           (setq newsymbol (make-symbol newname))))
 195     newsymbol))
 196
 197 (provide 'liece-inlines)
 198
 199 ;;; liece-inlines.el ends here