git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-clfns.el

   1 ;;; gnus-clfns.el --- compiler macros for emulating cl functions
   2 ;; Copyright (C) 2000 Free Software Foundation, Inc.
   3
   4 ;; Author: Kastsumi Yamaoka <yamaoka@jpl.org>
   5 ;; Keywords: cl, compile
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; Avoid cl runtime functions for FSF Emacsen.
  27
  28 ;;; Code:
  29
  30 (if (featurep 'xemacs)
  31     nil
  32   (require 'cl)
  33
  34   (define-compiler-macro last (&whole form x &optional n)
  35     (if (and (fboundp 'last)
  36              (subrp (symbol-function 'last)))
  37         form
  38       (if n
  39           `(let* ((x ,x)
  40                   (n ,n)
  41                   (m 0)
  42                   (p x))
  43              (while (consp p)
  44                (incf m)
  45                (pop p))
  46              (if (<= n 0)
  47                  p
  48                (if (< n m)
  49                    (nthcdr (- m n) x)
  50                  x)))
  51         `(let ((x ,x))
  52            (while (consp (cdr x))
  53              (pop x))
  54            x))))
  55
  56   (define-compiler-macro mapc (&whole form fn seq &rest rest)
  57     (if (and (fboundp 'mapc)
  58              (subrp (symbol-function 'mapc)))
  59         form
  60       (if rest
  61           `(let* ((fn ,fn)
  62                   (seq ,seq)
  63                   (args (list seq ,@rest))
  64                   (m (apply (function min) (mapcar (function length) args)))
  65                   (n 0))
  66              (while (< n m)
  67                (apply fn (mapcar (function (lambda (arg) (nth n arg))) args))
  68                (setq n (1+ n)))
  69              seq)
  70         `(let ((seq ,seq))
  71            (mapcar ,fn seq)
  72            seq))))
  73
  74   (define-compiler-macro mapcon (&whole form fn seq &rest rest)
  75     (if (and (fboundp 'mapcon)
  76              (subrp (symbol-function 'mapcon)))
  77         form
  78       (if rest
  79           `(let ((fn ,fn)
  80                  res
  81                  (args (list ,seq ,@rest))
  82                  p)
  83              (while (not (memq nil args))
  84                (push (apply ,fn args) res)
  85                (setq p args)
  86                (while p
  87                  (setcar p (cdr (pop p)))
  88                  ))
  89              (apply (function nconc) (nreverse res)))
  90         `(let ((fn ,fn)
  91                res
  92                (arg ,seq))
  93            (while arg
  94              (push (funcall ,fn arg) res)
  95              (setq arg (cdr arg)))
  96            (apply (function nconc) (nreverse res))))))
  97
  98   (define-compiler-macro member-if (&whole form pred list)
  99     (if (and (fboundp 'member-if)
 100              (subrp (symbol-function 'member-if)))
 101         form
 102       `(let ((fn ,pred)
 103              (seq ,list))
 104          (while (and seq
 105                      (not (funcall fn (car seq))))
 106            (pop seq))
 107          seq)))
 108
 109   (define-compiler-macro union (&whole form list1 list2)
 110     (if (and (fboundp 'union)
 111              (subrp (symbol-function 'union)))
 112         form
 113       `(let ((a ,list1)
 114              (b ,list2))
 115          (cond ((null a) b)
 116                ((null b) a)
 117                ((equal a b) a)
 118                (t
 119                 (or (>= (length a) (length b))
 120                     (setq a (prog1 b (setq b a))))
 121                 (while b
 122                   (or (memq (car b) a)
 123                       (push (car b) a))
 124                   (pop b))
 125                 a)))))
 126   )
 127
 128 (provide 'gnus-clfns)
 129
 130 ;;; gnus-clfns.el ends here