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, 2001 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 ;; This module is for mainly avoiding cl runtime functions in FSF
  27 ;; Emacsen.  Function should also be defined as an ordinary function
  28 ;; if it will not be provided in cl.
  29
  30 ;;; Code:
  31
  32 (if (featurep 'xemacs)
  33     nil
  34   (require 'cl)
  35   (require 'pym)
  36
  37   (define-compiler-macro butlast (&whole form x &optional n)
  38     (if (and (fboundp 'butlast)
  39              (subrp (symbol-function 'butlast)))
  40         form
  41       (if n
  42           `(let ((x ,x)
  43                  (n ,n))
  44              (if (and n (<= n 0))
  45                  x
  46                (let ((m (length x)))
  47                  (or n (setq n 1))
  48                  (and (< n m)
  49                       (progn
  50                         (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
  51                         x)))))
  52         `(let* ((x ,x)
  53                 (m (length x)))
  54            (and (< 1 m)
  55                 (progn
  56                   (setcdr (nthcdr (- m 2) x) nil)
  57                   x))))))
  58
  59   (define-compiler-macro coerce (&whole form x type)
  60     (if (and (fboundp 'coerce)
  61              (subrp (symbol-function 'coerce)))
  62         form
  63       `(let ((x ,x)
  64              (type ,type))
  65          (cond ((eq type 'list) (if (listp x) x (append x nil)))
  66                ((eq type 'vector) (if (vectorp x) x (vconcat x)))
  67                ((eq type 'string) (if (stringp x) x (concat x)))
  68                ((eq type 'array) (if (arrayp x) x (vconcat x)))
  69                ((and (eq type 'character) (stringp x) (= (length x) 1))
  70                 (aref x 0))
  71                ((and (eq type 'character) (symbolp x)
  72                      (= (length (symbol-name x)) 1))
  73                 (aref (symbol-name x) 0))
  74                ((eq type 'float) (float x))
  75                ((typep x type) x)
  76                (t (error "Can't coerce %s to type %s" x type))))))
  77
  78   (define-compiler-macro last (&whole form x &optional n)
  79     (if (and (fboundp 'last)
  80              (subrp (symbol-function 'last)))
  81         form
  82       (if n
  83           `(let* ((x ,x)
  84                   (n ,n)
  85                   (m 0)
  86                   (p x))
  87              (while (consp p)
  88                (incf m)
  89                (pop p))
  90              (if (<= n 0)
  91                  p
  92                (if (< n m)
  93                    (nthcdr (- m n) x)
  94                  x)))
  95         `(let ((x ,x))
  96            (while (consp (cdr x))
  97              (pop x))
  98            x))))
  99
 100   (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
 101     (if (and (fboundp 'merge)
 102              (subrp (symbol-function 'merge)))
 103         form
 104       `(let ((type ,type)
 105              (seq1 ,seq1)
 106              (seq2 ,seq2)
 107              (pred ,pred))
 108          (or (listp seq1) (setq seq1 (append seq1 nil)))
 109          (or (listp seq2) (setq seq2 (append seq2 nil)))
 110          (let ((res nil))
 111            (while (and seq1 seq2)
 112              (if (funcall pred (car seq2) (car seq1))
 113                  (push (pop seq2) res)
 114                (push (pop seq1) res)))
 115            (coerce (nconc (nreverse res) seq1 seq2) type)))))
 116
 117   (define-compiler-macro string (&whole form &rest args)
 118     (if (and (fboundp 'string)
 119              (subrp (symbol-function 'string)))
 120         form
 121       (list 'concat (cons 'list args))))
 122
 123   (defun-maybe string (&rest args)
 124     "Concatenate all the argument characters and make the result a string."
 125     (concat args))
 126
 127   (define-compiler-macro subseq (&whole form seq start &optional end)
 128     (if (and (fboundp 'subseq)
 129              (subrp (symbol-function 'subseq)))
 130         form
 131       (if end
 132           `(let ((seq ,seq)
 133                  (start ,start)
 134                  (end ,end))
 135              (if (stringp seq)
 136                  (substring seq start end)
 137                (let (len)
 138                  (if (< end 0)
 139                      (setq end (+ end (setq len (length seq)))))
 140                  (if (< start 0)
 141                      (setq start (+ start (or len (setq len (length seq))))))
 142                  (cond ((listp seq)
 143                         (if (> start 0)
 144                             (setq seq (nthcdr start seq)))
 145                         (let ((res nil))
 146                           (while (>= (setq end (1- end)) start)
 147                             (push (pop seq) res))
 148                           (nreverse res)))
 149                        (t
 150                         (let ((res (make-vector (max (- end start) 0) nil))
 151                               (i 0))
 152                           (while (< start end)
 153                             (aset res i (aref seq start))
 154                             (setq i (1+ i)
 155                                   start (1+ start)))
 156                           res))))))
 157         `(let ((seq ,seq)
 158                (start ,start))
 159            (if (stringp seq)
 160                (substring seq start)
 161              (let (len)
 162                (if (< start 0)
 163                    (setq start (+ start (or len (setq len (length seq))))))
 164                (cond ((listp seq)
 165                       (if (> start 0)
 166                           (setq seq (nthcdr start seq)))
 167                       (copy-sequence seq))
 168                      (t
 169                       (let* ((end (or len (length seq)))
 170                              (res (make-vector (max (- end start) 0) nil))
 171                              (i 0))
 172                         (while (< start end)
 173                           (aset res i (aref seq start))
 174                           (setq i (1+ i)
 175                                 start (1+ start)))
 176                         res)))))))))
 177   )
 178
 179 (provide 'gnus-clfns)
 180
 181 ;;; gnus-clfns.el ends here