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