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 (defsubst 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-member (thing list)
  58   "Returns t if thing is member of list, not funcallable"
  59   (member-if
  60    (lambda (item)
  61      (and (stringp item) (string-equal thing item)))
  62    list))
  63
  64 (defsubst string-list-remove-ignore-case (thing list)
  65   (remove-if
  66    (lambda (item)
  67      (and (stringp item) (string-equal-ignore-case item thing)))
  68    list))
  69
  70 (defsubst string-list-delete-ignore-case (thing list)
  71   (delete-if
  72    (lambda (item)
  73      (and (stringp item) (string-equal-ignore-case item thing)))
  74    list))
  75
  76 (defsubst string-list-remove (thing list)
  77   (remove-if
  78    (lambda (item)
  79      (and (stringp item) (string-equal item thing)))
  80    list))
  81
  82 (defsubst string-list-delete (thing list)
  83   (delete-if
  84    (lambda (item)
  85      (and (stringp item) (string-equal item thing)))
  86    list))
  87
  88 (defsubst string-list-modify-ignore-case (modifiers list)
  89   (dolist (modifier modifiers)
  90     (let ((p list))
  91       (while p
  92         (if (string-equal-ignore-case (car modifier) (car p))
  93             (setcar p (cdr modifier)))
  94         (setq p (cdr p)))))
  95   list)
  96
  97 (defsubst string-assoc-ignore-case (key list)
  98   (assoc-if
  99    (lambda (item) (string-equal-ignore-case item key))
 100    list))
 101
 102 (defsubst regexp-assoc-ignore-case (key list)
 103   "Assoc with REGEXP-KEY from LIST."
 104   (save-match-data
 105     (assoc-if
 106      (lambda (item)
 107        (string-match (concat "^" (upcase key)) "$") (upcase item))
 108      list)))
 109
 110 (defsubst regexp-rassoc-ignore-case (key list)
 111   "Assoc with KEY from LIST, in which keys are regexps."
 112   (rassoc-if
 113    (lambda (item)
 114      (string-match (concat "^" (upcase key) "$") (upcase item)))
 115    list))
 116
 117 (defmacro list-to-alist (list)
 118   `(mapcar #'list ,list))
 119
 120 (put 'filter-elements 'lisp-indent-function 2)
 121
 122 (defmacro filter-elements (element list condition)
 123   `(let (result tail ,element)
 124      (setq tail ,list)
 125      (while tail
 126        (setq ,element (car tail))
 127        (if ,condition
 128            (setq result (cons ,element result)))
 129        (setq tail (cdr tail)))
 130      (nreverse result)))
 131
 132 \f
 133 ;;; @ helper functions
 134 ;;;
 135 (defmacro liece-functionp (form)
 136   `(or (and (symbolp ,form) (fboundp ,form))
 137        (and (listp ,form) (eq (car ,form) 'lambda))
 138        (byte-code-function-p ,form)))
 139
 140 (defun liece-eval-form (form)
 141   (cond
 142    ((and (listp form) (liece-functionp (car form)))
 143     (eval form))
 144    ((and (symbolp form) (boundp form))
 145     (symbol-value form))
 146    (t form)))
 147
 148 (defun liece-or (&rest elems)
 149   "Return non-nil if any of the elements are non-nil."
 150   (catch 'found
 151     (while elems
 152       (when (pop elems)
 153         (throw 'found t)))))
 154
 155 (defun liece-and (&rest elems)
 156   "Return non-nil if all of the elements are non-nil."
 157   (catch 'found
 158     (while elems
 159       (unless (pop elems)
 160         (throw 'found nil)))
 161     t))
 162
 163 (defun liece-locate-path (subdir &optional filename)
 164   (let ((dir (liece-locate-data-directory
 165               (downcase (product-name (product-find 'liece-version))))))
 166     (when (and dir (file-directory-p dir))
 167       (if filename
 168           (expand-file-name filename (concat dir subdir))
 169         (concat dir subdir)))))
 170
 171 (defun liece-locate-icon-file (filename)
 172   (if (null liece-icon-directory)
 173       (setq liece-icon-directory (liece-locate-path "icons")))
 174   (setq filename (expand-file-name filename liece-icon-directory))
 175   (if (and filename (file-exists-p filename))
 176       filename))
 177
 178 (defmacro liece-next-line (arg)
 179   `(let ((i 0))
 180      (while (< i ,arg)
 181        (if (eobp) (newline)(next-line 1))
 182        (setq i (1+ i)))))
 183
 184 ;; Borrowed from `edebug.el'.
 185 (defvar liece-gensym-index 0
 186   "Integer used by `liece-gensym' to produce new names.")
 187
 188 (defun liece-gensym (&optional prefix)
 189   "Generate a fresh uninterned symbol.
 190 There is an  optional argument, PREFIX.  PREFIX is the
 191 string that begins the new name. Most people take just the default,
 192 except when debugging needs suggest otherwise."
 193   (if (null prefix)
 194       (setq prefix "G"))
 195   (let ((newsymbol nil)
 196         (newname   ""))
 197     (while (not newsymbol)
 198       (setq newname (concat prefix (int-to-string liece-gensym-index))
 199             liece-gensym-index (1+ liece-gensym-index))
 200       (if (not (intern-soft newname))
 201           (setq newsymbol (make-symbol newname))))
 202     newsymbol))
 203
 204 (provide 'liece-inlines)
 205
 206 ;;; liece-inlines.el ends here